Advertisement
ZOOOO

Untitled

Nov 20th, 2015
9,547
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Scheme 2.16 KB | None | 0 0
  1. (define (make-source src . end)
  2.   (let ((lst (cond
  3.                ((string? src) (string->list src))
  4.                ((vector? src) (vector->list src))
  5.                (else src)))
  6.         (mend (and (not (null? end)) (car end))))
  7.     (cons lst mend)))
  8. (define (next source)
  9.   (if (null? (car source))
  10.       (cdr source)
  11.       (let ((ret (caar source)))
  12.         (set-car! source (cdar source))
  13.         ret)))
  14.  
  15. (define (parse vec)
  16.   (define return 1)
  17.   (define cl 1)
  18.   (define src (make-source vec))
  19.   (define (nl) (set! cl (next src)))
  20.   (define (parse-body)
  21.     (cond
  22.       ((equal? cl 'if) (list cl
  23.                              (let loop ((res '()))
  24.                                (nl)
  25.                                (if (and cl (not (equal? cl 'endif)))
  26.                                    (loop (cons (parse-body) res))
  27.                                    (if (equal? cl 'endif)
  28.                                        (reverse res)
  29.                                        (return #f))))))
  30.       ((member cl '(end endif define)) (return #f))
  31.       ((symbol? cl) cl)
  32.       ((number? cl) cl)
  33.       (else (return #f))))
  34.   (define (parse-article)
  35.     ;(if (equal? cl 'define)
  36.     (begin
  37.       (nl)
  38.       (list cl
  39.             (let loop ((res '()))
  40.               (nl)
  41.               (if (and cl (not (equal? cl 'end)))
  42.                   (let ((tmp (parse-body)))
  43.                     (if tmp
  44.                         (loop (cons tmp res))
  45.                         (return #f)))
  46.                   (if (equal? cl 'end)
  47.                       (begin (nl) (reverse res))
  48.                       (return #f))))))
  49.     ;#f)
  50.     )
  51.   (define (parse-articles)
  52.     (let loop ((rs '()))
  53.       (if (equal? cl 'define)
  54.           (let ((tmp (parse-article)))
  55.             (loop (cons tmp rs)))
  56.           (reverse rs))))
  57.   (define (parse-program)
  58.     (list
  59.      (parse-articles)
  60.      (let loop ((res '()))
  61.        (if cl
  62.            (let ((prev (parse-body)))
  63.              (nl)
  64.              (if prev
  65.                  (loop (cons prev res))
  66.                  (return #f)))
  67.            (reverse res)))))
  68.   (call/cc (lambda (exit) (set! return exit) (nl) (parse-program))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement