Preprocessor for Meta-expression

gistfile1.txt

;;Sapphire preprocessor
;;Meta-language

(define tokens '())
(define tokens1 '()) ;;for look ahead
(define cc #f)
(define semicolon-end? #f)
(define period-end? #f)
(define bracket-end? #f)
(define then-end? #f)
(define curl-end? #f)

(define (sapphire)
  (set! tokens '())
  (set! tokens1 '())
  (set! semicolon-end? #f)
  (set! period-end? #f)
  (set! bracket-end? #f)
  (set! then-end? #f)
  (parse))

(define (repl)
  (display "*> ")
  (let loop ((mexp (parse)))
    (cond ((equal? mexp '(exit)) #t)
          (else
            (display (eval mexp (interaction-environment)))
            (newline)
            (display "*> ")
            (loop (parse))))))

;;スキャナ
(define (butlast ls)
  (reverse (cdr (reverse ls))))

(define (addlast x ls)
  (reverse (cons x (reverse ls))))

(define (read-lines)
  (let loop ((s (read-line))
             (ss ""))
    (cond ((eof-object? s) (cc s))
          ((string=? s "") (loop (read-line) ss))
          ((string=? s "#!scheme") (language 'scheme) (cc #t))
          ((string=? s "#!sapphire") (language 'sapphire) (cc #t))
          ((end-line? s) (string-append ss " " s))
          ((char=? (string-ref s 0) #\%) (loop (read-line) ss))
          (else
            (loop (read-line)(string-append ss " " s))))))

(define (end-line? s)
  (if (string=? s "")
      #f
      (let ((l (string-length s)))
        (let loop ((i (- l 1)))
          (let ((c (string-ref s i)))
            (cond ((char=? c #\.) #t)
                  ((= i 0) #f)
                  ((char=? c #\space)(loop (- i 1)))
                  (else #f)))))))

(define (save-tokens)
  (set! tokens1 (cons tokens tokens1)))

(define (restore-tokens)
  (set! tokens (car tokens1))
  (set! tokens1 (cdr tokens1)))

(define (get-token)
  (cond ((null? tokens)
         (set! tokens (get-token2))
         (pop-token))
        (else
          (pop-token))))

(define (pop-token)
  (let ((res (car tokens)))
    (set! tokens (cdr tokens))
    res))

(define (unget-token x)
  (set! tokens (cons x tokens)))


(define (get-token2)
  (get-token3 (string->list (read-lines))))

(define (get-token3 ls)
  (cond ((null? ls) '())
        (else
          (let-values (((token rest)(get-token4 (space-skip ls))))
            (let ((tok (construct token)))
              (if (list? tok)
                  (append tok (get-token3 rest))
                  (cons tok (get-token3 rest))))))))


(define (construct ls)
  (cond ((string-period? ls) #\.)
        ((string->number (list->string ls)) (string->number (list->string ls)))
        ((string-symbol? ls) (string->symbol (list->string ls)))
        ((string-sharp? ls) #\#)
        ((string-matrix? ls) #\%)
        ((string-true? ls) #t)
        ((string-false? ls) #f)
        ((string-lparen? ls) #\()
        ((string-rparen? ls) #\))
        ((string-lbracket? ls) #\[)
        ((string-rbracket? ls) #\])
        ((string-lcurl? ls) #\{)
        ((string-rcurl? ls) #\})
        ((string-comma? ls) #\,)
        ((string-quote? ls) #\')
        ((string-semicolon? ls) #\;)
        ((string-string? ls) (list->string (cddr (reverse (cddr (reverse ls))))))
        ((string-imag? ls) (list (string->number (list->string (butlast ls)))
                                 'i))
        (else
          (error "Sapphire: illegal identifier" (string->symbol (list->string ls))))))


(define (string-symbol? ls)
  (or (char-alphabetic? (car ls))
      (char=? (car ls) #\+)
      (char=? (car ls) #\-)
      (char=? (car ls) #\*)
      (char=? (car ls) #\/)
      (char=? (car ls) #\^)
      (char=? (car ls) #\=)
      (char=? (car ls) #\>)
      (char=? (car ls) #\<)
      (char=? (car ls) #\!)
      (char=? (car ls) #\&)
      (char=? (car ls) #\:)
      (char=? (car ls) #\.)
      (char=? (car ls) #\|)))

(define (string-semicolon? ls)
  (char=? (car ls) #\;))

(define (string-period? ls)
  (char=? (car ls) #\.))

(define (string-lparen? ls)
  (char=? (car ls) #\())
  
(define (string-rparen? ls)
  (char=? (car ls) #\)))

(define (string-lbracket? ls)
  (char=? (car ls) #\[))

(define (string-rbracket? ls)
  (char=? (car ls) #\]))

(define (string-lcurl? ls)
  (char=? (car ls) #\{))

(define (string-rcurl? ls)
  (char=? (car ls) #\}))
 
(define (string-true? ls)
  (and (char=? (car ls) #\#)
       (char=? (cadr ls) #\t)))

(define (string-false? ls)
  (and (char=? (car ls) #\#)
       (char=? (cadr ls) #\f)))

(define (string-imag? ls)
  (and (char-numeric? (car ls))
       (string->number (list->string (butlast ls)))
       (char=? #\i (car (reverse ls)))))

(define (string-comma? ls)
  (char=? (car ls) #\,))

(define (string-quote? ls)
  (char=? (car ls) #\'))

(define (string-string? ls)
  (char=? (car ls) #\"))

(define (string-sharp? ls)
  (and (= (length ls) 1)
       (char=? (car ls) #\#)))

(define (string-matrix? ls)
  (and (= (length ls) 2)
       (char=? (car ls) #\#)
       (char=? (cadr ls) #\m)))

(define (space-skip ls)
  (cond ((null? ls) ls)
        ((char=? (car ls) #\space) (space-skip (cdr ls)))
        ((char=? (car ls) #\tab) (space-skip (cdr ls)))
        (else ls)))

(define (get-token4 ls)
  (let loop ((token '())(rest ls))
    (cond ((null? rest) (values (reverse token) rest))
          ((string-string? ls) (get-string (cdr ls)(list (cadr ls)(car ls))))
          ((string-reserve? ls)
           (values (list (car ls) (cadr ls) (caddr ls)) (cdddr rest)))
          ((string-operator? ls)
           (values (list (car ls) (cadr ls))(cddr rest)))
          ((and (delimiter? (car rest))
                (null? token))
           (values (list (car rest)) (cdr rest)))
          ((and (delimiter1? rest)
                (null? token))
           (values (list (car rest)(cadr rest)(caddr rest)) (cdddr rest)))
          ((delimiter? (car rest)) (values (reverse token) rest))
          ((delimiter1? rest) (values (reverse token) rest))
          (else
            (loop (cons (car rest) token)(cdr rest))))))

(define (get-string ls str)
  (cond ((null? ls) (sapphire-error "Sapphire: illegal string"))
        ((string-string? ls) (values (reverse 
                                       (cons (car ls)
                                             (cons (cadr ls) str)))
                                     (cdr ls)))
        (else
          (get-string (cdr ls)
                      (cons (car ls) str)))))

(define (string-reserve? ls)
  (cond ((and (>= (length ls) 3)
              (char=? (car ls) #\<)
              (char=? (cadr ls) #\=)
              (char=? (caddr ls) #\=))
         #t)
        (else #f)))

(define (string-operator? ls)
  (cond ((and (>= (length ls) 2)(char=? (car ls) #\:)(char=? (cadr ls) #\=))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\+)(char=? (cadr ls) #\+))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\-)(char=? (cadr ls) #\-))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\=)(char=? (cadr ls) #\=))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\&)(char=? (cadr ls) #\&))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\|)(char=? (cadr ls) #\|))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\>)(char=? (cadr ls) #\=))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\=)(char=? (cadr ls) #\>))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\<)(char=? (cadr ls) #\=))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\=)(char=? (cadr ls) #\<))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\!)(char=? (cadr ls) #\=))
         #t)
        ((and (>= (length ls) 2)(char=? (car ls) #\-)(char=? (cadr ls) #\>))
         #t)
        
        (else #f)))

(define (delimiter? x)
  (case x
    ((#\+ #\- #\* #\/ #\( #\) #\[ #\] #\{ #\} #\space #\tab #\^ #\= #\: #\> #\< #\, #\' #\! #\| #\& #\; #\.) #t)
    (else #f)))

(define (delimiter1? ls)
  (cond ((and (>= (length ls) 3)(char=? (car ls) #\m)(char=? (cadr ls) #\o)(char=? (caddr ls) #\d))
         #t)
        ((and (>= (length ls) 3)(char=? (car ls) #\d)(char=? (cadr ls) #\i)(char=? (caddr ls) #\v))
         #t)
        (else #f)))
 

;;パーザー　構文解析
(define (parse)
  (call/cc 
    (lambda (c)
      (set! cc c)
      (let ((x (get-token)))
        (cond ((quote? x) (list 'quote (parse)))
              ((assignment? x) (parse-assignment x))
              ((definition? x) (parse-difinition x))
              ((condition? x) (parse-condition))
              (else 
                (unget-token x)
                (parse-formula)))))))


(define (assignment? x)
  (let ((x2 (get-token)))
    (cond ((and (symbol? x)(eqv? x2 ':=)) #t)
          (else
            (unget-token x2) #f))))

(define (parse-assignment x)
  (let ((form (parse)))
    (list 'set! x form)))

(define (definition? x)
  (save-tokens)
  (let ((x2 (get-token))(x3 #f)(x4 #f))
    (cond ((and (symbol? x)(lbracket? x2))
           (set! x3 (get-tuple))
           (set! x4 (get-token))
           (cond ((and (symbol? x)(list? x3)(eqv? x4 '<==))
                  (restore-tokens) #t)
                 (else
                   (restore-tokens) #f)))
          ((and (symbol? x)(eqv? x2 '<==))
           (restore-tokens) #t)
          (else
            (restore-tokens) #f))))

            
(define (parse-difinition x)
  (let* ((x2 (get-token))
         (x3 #f)
         (x4 #f)
         (x5 #f))
    (cond ((lbracket? x2)
           (set! x3 (get-tuple))
           (set! x4 (get-token))
           (set! x5 (parse))
           (list 'define x (list 'lambda x3 x5)))
          (else
            (set! x3 (parse))
            (list 'define x x3)))))

(define (condition? x)
  (cond ((not (lbracket? x)) #f)
        (else
          (cond ((condition1?) #t)
                (else
                  #f)))))

(define (condition1?)
  (save-tokens)
  (set! then-end? #f)
  (parse)
  (restore-tokens)
  (if then-end?
      #t
      #f))
  
(define (parse-condition)
  (let loop ((ls '()))
    (let* ((x1 (parse))
           (x2 (parse)))
      (cond (bracket-end? 
              (set! bracket-end? #f)
              (get-token)
              (cons 'cond (reverse (cons (cons x1 (list x2)) ls))))
            (else
              (loop (cons (cons x1 (list x2)) ls)))))))

      
(define (get-term)
  (let ((x (get-token)))
    (cond ((number? x) (get-number x))
          ((symbol? x) (get-symbol x))
          ((lparen? x) (list 'quote (get-list)))
          ((lbracket? x) (get-tuple))
          ((quote? x) (list 'quote (get-term)))
          ((sharp-vector? x) (apply vector (get-list)))
          ((sharp-matrix? x) (apply list->matrix (list (get-list))))
          (else x))))


(define (get-list)
  (let ((x (get-token)))
    (cond ((rparen? x) '())
          ((period? x) (get-list))
          ((lparen? x) (cons (get-list)(get-list)))
          (else
            (cons x (get-list))))))


(define (get-tuple)
  (let ((x (get-token)))
    (cond ((rbracket? x) '())
          (else
            (unget-token x)
            (get-tuple1 '())))))

(define (get-tuple1 ls)
  (set! bracket-end? #f)
  (let ((x (parse-formula)))
    (cond (bracket-end? 
            (set! bracket-end? #f)
            (reverse (cons x ls)))
          (else
            (get-tuple1 (cons x ls))))))


(define (get-symbol x)
  (let ((x2 (get-token)))
    (cond ((operator? x) (unget-token x2) x)
          ((lbracket? x2)
           (let ((fn (assv x fn->proc))
                 (tup (get-tuple)))
           (if (not fn)
               (cons x tup)
               (cons (cadr fn) tup))))
          (else
            (unget-token x2)
            (let ((fn (assv x fn->proc)))
              (if (not fn)
                  x
                  (cadr fn)))))))

(define fn->proc
  '((fn lambda)
    (prog begin)
    (do for-each)
    (print display)
    (vecLen vector-length)
    (matLen matrix-length)
    (tensLen tensor-length)
    (listRef list-ref)
    (listTail list-tail)
    (listCopy list-copy)
    (strRef string-ref)
    (strAppend string-append)
    (realPart real-part)
    (imagPart imag-part)
    (listToVec list->vector)
    (vecToList vector->list)
    (strToList string->list)
    (listToStr list->string)
    (symToStr symbol->string)
    (makeTens make-tensor)
    (makeMat make-matrix)
    (makeRect make-rectangular)
    (makePolar make-polar)
    (makeList make-list)
    (makeVec make-vector)
    (listToMat list->matrix)
    (matToList matrix->list)))


(define (get-negative x)
  (let ((x2 (get-token)))
    (cond ((number? x2) (- (get-number x2)))
          (else
            (unget-token x2)))))

(define (get-positive x)
  (let ((x2 (get-token)))
    (cond ((number? x2) (get-number x2))
          (else
            (unget-token x2)))))


(define (get-number x)
  (cond ((>= (length tokens) 3)
         (let* ((x2 (get-token))
                (x3 (get-token))
                (x4 (get-token)))
           (cond ((and (or (eqv? x2 '+)(eqv? x2 '-))
                       (real? x3)
                       (eqv? x4 'i))
                  (if (eqv? x2 '+)
                      (make-rectangular x x3)
                      (make-rectangular x (- x3))))
                 (else
                   (unget-token x4)
                   (unget-token x3)
                   (unget-token x2)
                   x))))
        (else
          x)))



(define parse-operator? #f)
(define double-parse-operator? #f)

(define (operator? x)
  (cond ((memv  x '(+ - * / ^ = < > >= <= && || == != ! |\|| mod div))
         (cond (parse-operator? 
                 (set! parse-operator? #f)
                 (set! double-parse-operator? #t) #t)
               (else
                 (set! parse-operator? #t)
                 (set! double-parse-operator? #f)
                 #t)))
        (else
          (set! parse-operator? #f) #f)))

(define (weight x)
  (cond ((memv  x '(&& ||)) 0)
        ((memv  x '(= == != > < >= <= |\||)) 1)
        ((memv  x '(+ -)) 2)
        ((memv  x '(* /)) 4)
        ((memv  x '(^)) 5)
        ((memv  x '(! ++ --)) 10)
        ((list? x) 6)
        (else
          9)))

(define (operator->procedure x)
  (cond ((eqv? x '=) '=)
        ((eqv? x '>) '>)
        ((eqv? x '<) '<)
        ((eqv? x '>=) '>=)
        ((eqv? x '<=) '<=)
        ((eqv? x '==) 'equal?)
        ((eqv? x '!=) 'not-equal?)
        ((eqv? x '&&) 'and)
        ((eqv? x '||) 'or)
        ((eqv? x '+) '+)
        ((eqv? x '-) '-)
        ((eqv? x '*) '*)
        ((eqv? x '/) '/)
        ((eqv? x 'mod) 'modulo)
        ((eqv? x 'div) 'quotient)
        ((eqv? x '->) '->)
        ((eqv? x '^) 'expt)
        ((eqv? x '!) 'fact)
        ((eqv? x '|\||) 'divisible?)))

(define (not-equal? x y)
  (not (equal? x y)))

(define (fact n)
  (cond ((not (integer? n)) (sapphire-error "Sapphire: factorial require integer"))
        ((< n 0) (sapphire-error "Sapphire: factroial require not negative number"))
        (else
          (fact1 n))))

(define (fact1 n)
  (if (= n 0)
      1
      (* n (fact1 (- n 1)))))

(define (divisible? x y)
  (= (modulo y x) 0))
      

(define (semicolon? x)
  (and (char? x)(char=? x #\;)))

(define (period? x)
  (and (char? x)(char=? x #\.)))

(define (lparen? x)
  (and (char? x)(char=? x #\()))

(define (rparen? x)
  (and (char? x)(char=? x #\))))

(define (lbracket? x)
  (and (char? x)(char=? x #\[)))

(define (rbracket? x)
  (and (char? x)(char=? x #\])))

(define (lcurl? x)
  (and (char? x)(char=? x #\{)))

(define (rcurl? x)
  (and (char? x)(char=? x #\})))

(define (comma? x)
  (and (char? x)(char=? x #\,)))

(define (quote? x)
  (and (char? x)(char=? x #\')))

(define (then? x)
  (and (symbol? x)(eqv? x '->)))

(define (sharp-vector? x)
  (cond ((and (char? x)(char=? x #\#))
         (let ((x2 (get-token)))
           (cond ((lparen? x2) #t)
                 (else (unget-token x2) #f))))
        (else #f)))
               

(define (sharp-matrix? x)
  (cond ((and (char? x)(char=? x #\%))
         (let ((x2 (get-token)))
           (cond ((lparen? x2) #t)
                 (else (unget-token x2) #f))))
        (else #f)))

(define (parse-formula)
  (let* ((x (get-term))
         (y (get-token)))
    (cond ((semicolon? y) 
           (set! semicolon-end? #t) x)
          ((period? y)
           (if (rbracket? x) (sapphire-error "illegal form"))
           (set! period-end? #t) x)
          ((rbracket? y)
           (set! bracket-end? #t) x)
          ((then? y)
           (set! then-end? #t) x)
          ((lcurl? x) 
           (unget-token y)(parse-formula1 (list (parse-formula1 '() '())) '()))
          (else 
            (unget-token y)
            (if (operator? x)
                (parse-formula1 '() (list x))
                (parse-formula1 (list x) '()))))))

(define (parse-formula1 operand operator)
   (let ((x (get-term)))
     (cond ((rbracket? x)
            (set! bracket-end? #t)
            (parse-formula2 operand operator))
           ((semicolon? x)
            (set! semicolon-end? #t)
            (parse-formula2 operand operator))
           ((period? x)
            (set! period-end? #t)
            (parse-formula2 operand operator))
           ((rbracket? x)
            (set! bracket-end? #t)
            (parse-formula2 operand operator))
           ((then? x) 
            (set! then-end? #t)
            (parse-formula2 operand operator))
           ((rcurl? x)
            (set! curl-end? #t)
            (parse-formula2 operand operator))
           ((lbracket? x)
            (parse-formula1 (cons (parse-formula1 '() '()) operand) operator))
           ((lcurl? x)
            (parse-formula1 (cons (parse-formula1 '() '()) operand) operator))  
           ((and (operator? x)(= (weight x) 10))
            (parse-formula1 (cons (list (operator->procedure x)(car operand))(cdr operand))
                            operator)) 
           ((operator? x)
            (parse-formula1 operand (cons x operator)))
           ((and (not(null? operator))(eqv? (car operator) '-)(null? operand)(eqv? x 'i))
            (parse-formula1 (cons -i operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '-)(null? operand))
            (parse-formula1 (cons (list '- x) operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '-) double-parse-operator? (eqv? x 'i))
            (parse-formula1 (cons -i operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '-) double-parse-operator?)
            (parse-formula1 (cons (list '- x) operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '+)(null? operand)(eqv? x 'i))
            (parse-formula1 (cons +i operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '+)(null? operand))
            (parse-formula1 (cons x operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '+) double-parse-operator? (eqv? x 'i))
            (parse-formula1 (cons +i operand) (cdr operator)))
           ((and (not(null? operator))(eqv? (car operator) '+) double-parse-operator?)
            (parse-formula1 (cons (list '+ x) operand) (cdr operator)))
           ((and (= (length operator) 2)
                 (> (weight (car operator))
                    (weight (cadr operator)))
            (parse-formula1 (cons (list (operator->procedure (car operator)) (car operand) x) (cdr operand))
                            (cdr operator))))
           ((and (= (length operator) 2)
                 (eqv? (car operator) '^)
                 (eqv? (cadr operator) '^))
            (parse-formula1 (cons (list (operator->procedure (car operator)) (car operand) x) (cdr operand))
                            (cdr operator)))
           ((and (= (length operator) 2)
                 (<= (weight (car operator))
                     (weight (cadr operator))))
            (parse-formula1 (cons x
                                  (list (list (operator->procedure (cadr operator)) (cadr operand) (car operand))))
                            (list (car operator))))
           (else
             (parse-formula1 (cons x operand) operator)))))

(define (parse-formula2 operand operator)
  (cond ((and (> (length operand) 1)(null? operator))
         (sapphire-error "Sapphire: illegal formula too many operand" operand))
        ((and (< (length operand) 2)(not (null? operator)))
         (sapphire-error "Sapphire: illegal formula too few operand" operand))
        ((null? operator) (car operand))
        (else
          (parse-formula2 (cons (list (operator->procedure (car operator)) (cadr operand)(car operand))
                                (cddr operand))
                          (cdr operator)))))



(define (sapphire-error msg . arg)
  (if (null? arg)
      (begin (set! tokens '())(error msg))
      (begin (set! tokens '())(error msg (car arg)))))

Do you have a license for this code? It would be good in case someone wants to build an environment with it :)