gistfile1.txt

;;Sapphire  for r7rs test version
(import (scheme base)
        (scheme char)
        (scheme complex)
        (scheme eval)
        (scheme file)
        (scheme inexact)
        (scheme lazy)
        (scheme repl)
        (scheme process-context)
        (scheme write))


(define tokens '())
(define tokens1 '()) ;;for look ahead
(define cc #f)
(define paren-end? #f)
(define semicolon-end? #f)
(define bracket-end? #f)
(define comma-end? #f)
(define curl-end? #f)
(define begin-nest 0)
(define list-nest 0)
(define tuple-nest 0)
(define index-nest 0)

(define (sapphire)
  (set! tokens '())
  (set! begin-nest 0)
  (set! list-nest 0)
  (set! tuple-nest 0)
  (set! index-nest 0)
  (parse))

(define (repl)
  (display "Sapphire REPL")
  (let ((sexp '()))
    (let loop ()
      (newline)
      (display ">> ") (flush-output-port)
      (set! sexp (sapphire))
      (guard (e (else (display "Sapphire eval error")))
             (write (eval sexp (interaction-environment))))
      (loop))))


;;スキャナ
(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 tokens))

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

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

(define (pop-token)
  (let ((res (car tokens)))
    (if (rparen? res)
        (set! paren-end? #t)
        (set! paren-end? #f))
    (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->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-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-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-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)
        (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)
        ((and (>= (length ls) 2)(char=? (car ls) #\.)(char=? (cadr ls) #\.))
         #t)
        (else #f)))
 

;;パーザー　構文解析
(define (parse)
  (call/cc 
    (lambda (c)
      (set! cc c)
      (set! paren-end? #f)
      (set! semicolon-end? #f)
      (let ((x (get-token)))
        (cond ((semicolon? x) (sapphire-error "Sapphire: null expression"))
              ((reserved? x) (parse-syntax x))
              ((lcurl? x) (parse-begin))
              ((quote? x) (list 'quote (parse)))
              ((assignment? x) (parse-assignment x))
              ((assignment-index? x) (parse-assignment-index x))
              (else 
                (unget-token x)
                (parse-formula)))))))


(define (parse-syntax x)
  (cond ((eqv? x 'if)
         (parse-if x))
        ((eqv? x 'else)
          (sapphire-error "Sapphire syntax error. else without if"))
        ((eqv? x 'def)
         (parse-define x))
        ((eqv? x 'fn)
         (parse-lambda x))
        ((eqv? x 'let)
         (parse-let x))
        ((eqv? x 'for)
         (parse-for x))
        ((eqv? x 'while)
         (parse-while x))
        ((eqv? x 'when)
         (parse-when x))
        ((eqv? x 'unless)
         (parse-unless x))
        ((eqv? x 'catch)
         (parse-catch x))
        ((eqv? x 'throw)
         (parse-throw x))
        ((eqv? x 'import)
         (parse-import x))))

(define (parse-if x)
  (let ((test '())
        (true '())
        (false '()))
    (unless (lparen? (get-token)) (sapphire-error "Saphire: if require left paren at test formula"))
    (set! test (parse))
    (unless paren-end? (sapphire-error "Sapphire: if require right paren at test formula"))
    (set! true (parse))
    (when semicolon-end? (sapphire-error "Sapphire: if require else formula"))
    (unless (eqv? (get-token) 'else) (sapphire-error "Sapphire: if require else"))
    (set! false (parse))
    (list x test true false)))

(define (parse-define x)
  (let* ((y (parse-define1))
         (z (parse)))
    (unless (or semicolon-end? comma-end?) (sapphire-error "Sapphire: define require ; or , at end"))
    (if (and (list? z)(eqv? (car z) 'begin))
        (append (list 'define y) (cdr z))
        (list 'define y z))))

(define (parse-define1)
  (let* ((x1 (get-token))
         (x2 (get-token)))
    (cond ((and (symbol? x1)(lparen? x2))
           (cons x1 (get-tuple)))
          (else
            (unget-token x2)
            x1))))


(define (parse-begin)
  (set! begin-nest (+ begin-nest 1))
  (let loop ((x (get-token))(y '()))
    (cond ((rcurl? x)
           (set! begin-nest (- begin-nest 1))
           (let ((z (get-token)))
             (cond ((semicolon? z) (set! semicolon-end? #t))
                   ((comma? z) (set! comma-end? #t) #t)
                   (else (unget-token z)))
             (cons 'begin (reverse y))))
          (else
            (unget-token x)
            (set! comma-end? #f)
            (set! curl-end? #f)
            (let ((s (parse)))
              (when (and semicolon-end? (> begin-nest 0)) (sapphire-error "Sapphire: expect } before ;"))
              (loop (get-token)(cons s y)))))))

(define (parse-lambda x)
  (let* ((tok (get-token))
         (y (if (lparen? tok)(get-tuple) tok))
         (z (parse)))
    (if (and (list? z)(eqv? (car z) 'begin))
        (append (list 'lambda y) (cdr z))
        (list 'lambda y z))))

(define (parse-let x)
  (let loop ((y '()))
    (let ((tok (get-token)))
      (cond ((not (lparen? tok))
             (unget-token tok)
             (let ((z (parse)))
               (if (and (list? z)(eqv? (car z) 'begin))
                   (append (list x (reverse y)) (cdr z))
                   (list x (reverse y) z))))
          (else
            (let ((z (get-tuple)))
              (loop (cons z y))))))))

(define (parse-for x)
  (let ((tuple '())
        (body '()))
    (unless (lparen? (get-token)) (sapphire-error "Sapphire: for syntax require left pare at tuple"))
    (set! tuple (get-tuple))
    (unless paren-end? (sapphire-error "Sapphire: for syntax reuqire right paren at tuple"))
    (unless (= (length tuple) 3) (sapphire-error "Sapphire: for syntax require 3 element tuple" tuple)) 
    (set! body (parse))
    (if (and (list? body)(eqv? (car body) 'begin))
        (cons 'for (cons tuple (cdr body)))
        (cons 'for (cons tuple (list body)))))) 

(define (parse-while x)
  (let ((test '())
        (true '()))
    (unless (lparen? (get-token)) (sapphire-error "Saphire: while require left paren at test formula"))
    (set! test (parse))
    (unless paren-end? (sapphire-error "Sapphire: while require right paren at test formula"))
    (set! true (parse))
    (if (and (list? true)(eqv? (car true) 'begin))
        (cons 'while (cons test (cdr true)))
        (cons 'while (cons test (list true))))))

(define (parse-when x)
  (let ((test '())
        (true '()))
    (unless (lparen? (get-token)) (sapphire-error "Saphire: when require left paren at test formula"))
    (set! test (parse))
    (unless paren-end? (sapphire-error "Sapphire: when require right paren at test formula"))
    (set! true (parse))
    (if (and (list? true)(eqv? (car true) 'begin))
        (cons x (cons test (cdr true)))
        (cons x (cons test (list true))))))


(define (parse-unless x)
  (let ((test '())
        (true '()))
    (unless (lparen? (get-token)) (sapphire-error "Saphire: unless require left paren at test formula"))
    (set! test (parse))
    (unless paren-end? (sapphire-error "Sapphire: unless require right paren at test formula"))
    (set! true (parse))
    (if (and (list? true)(eqv? (car true) 'begin))
        (cons x (cons test (cdr true)))
        (cons x (cons test (list true))))))

(define (parse-catch x)
  (let ((tag '())
        (body '()))
    (set! tag (get-token))
    (unless (symbol? tag) (sapphire-error "Sapphire: catch require tag"))
    (set! body (parse))
    (if (and (list? body)(eqv? (car body) 'begin))
        (cons 'catch (cons tag (cdr body)))
        (cons 'catch (cons tag (list body))))))

(define (parse-throw x)
  (let ((tag '())
        (val '()))
    (set! tag (get-token))
    (unless (symbol? tag) (sapphire-error "Sapphire: throw require tag"))
    (set! val (parse))
    (list 'throw tag val)))

(define (parse-import x)
  (let ((tuple '()))
    (unless (lparen? (get-token)) (sapphire-error "Sapphire: import syntax require left pare at tuple"))
    (set! tuple (get-tuple))
    (unless paren-end? (sapphire-error "Sapphire: import syntax reuqire right paren at tuple"))
    (list x tuple)))
  


(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 (assignment-index? x)
  (save-tokens)
  (let ((x2 (get-token))(x3 #f)(x4 #f))
    (cond ((and (symbol? x)(lbracket? x2))
           (set! x3 (get-index))
           (set! x4 (get-token))
           (cond ((and (symbol? x)(list? x3)(eqv? x4 ':=))
                  (restore-tokens) #t)
                 (else
                   (restore-tokens) #f)))
          (else
            (restore-tokens) #f))))

            
(define (parse-assignment-index x)
  (let* ((x2 (get-token))
         (x3 (get-index))
         (x4 (get-token))
         (x5 (parse)))
    (cond ((= (length x3) 1) (list 'vector-set1! x (car x3) x5))
          ((= (length x3) 2) (list 'matrix-set1! x (car x3) (cadr x3) x5))
          ((>= (length x3) 3) (list 'tensor-set1! x (cons 'list x3) x5))
          (else
            (sapphire-error "Sapphire: illegal index" x3)))))


(define (get-element)
  (let ((x (get-token)))
    (cond ((semicolon? x) x)
          ((boolean? x) x)
          ((vector? x) x)
          ((bytevector? x) x)
          ((string? x) x)
          ((eqv? x '-) (get-negative x))
          ((eqv? x '+) (get-positive x))
          ((number? x) (get-number x))
          ((symbol? x) (get-symbol x))
          ((lbracket? x) (list 'quote (get-list)))
          ((sharp? x) (apply vector (get-list)))
          ((sharp-matrix? x) (apply list->matrix (list (cadr (get-term)))))
          ((or (lparen? x)(rparen? x)(lbracket? x)(rbracket? x)) x)
          ((comma? x) x)
          (else x))))

(define (get-term)
  (let ((x (get-token)))
    (cond ((semicolon? x) x)
          ((boolean? x) x)
          ((vector? x) x)
          ((bytevector? x) x)
          ((string? x) x)
          ((number? x) (get-number x))
          ((symbol? x) (get-symbol x))
          ((sequence? x) (list 'quote (get-seq x)))
          ((lbracket? x) (list 'quote (get-list)))
          ((sharp? x) (apply vector (get-list)))
          ((sharp-matrix? x) (apply list->matrix (list (cadr (get-term)))))
          ((or (lparen? x)(rparen? x)(lbracket? x)(rbracket? x)) x)
          ((comma? x) x)
          (else x))))

(define (sequence? x)
  (cond ((and (lbracket? x)(>= (length tokens) 4))
         (let* ((x2 (get-token))
                (x3 (get-token))
                (x4 (get-token))
                (x5 (get-token)))
           (cond ((and (integer? x2)
                       (eqv? x3 '..)
                       (integer? x4)
                       (rbracket? x5))
                  (unget-token x5)
                  (unget-token x4)
                  (unget-token x3)
                  (unget-token x2)
                  #t)
                 (else
                   (unget-token x5)
                   (unget-token x4)
                   (unget-token x3)
                   (unget-token x2)
                   #f))))
        (else #f)))

(define (get-seq x)
  (let* ((x2 (get-token))
         (x3 (get-token))
         (x4 (get-token))
         (x5 (get-token)))
    (iota x2 x4)))



(define (get-list)
  (set! list-nest (+ list-nest 1))
  (let ((x2 (get-element)))
    (cond ((rbracket? x2)
           (set! list-nest (- list-nest 1)) '())
          ((and (list? x2)(eqv? (car x2) 'quote)) (cons (cadr x2)(get-list1)))
          (else
            (let ((x3 (get-token)))
              (cond ((rbracket? x3) 
                     (set! list-nest (- list-nest 1)) ((list x2)))
                    (else
                      (unget-token x3)
                      (cons x2 (get-list1)))))))))

(define (get-list1)
  (let ((x2 (get-element)))
    (cond ((rbracket? x2) 
           (set! list-nest (- list-nest 1)) '())
          ((comma? x2)
           (let ((x3 (get-element))) 
             (cond ((and (list? x3)(eqv? (car x3) 'quote)) (cons (cadr x3)(get-list1)))
                   (else
                     (cons x3 (get-list1))))))
          (else 
            (sapphire-error "Sapphire: illegal list")))))

(define (get-index)
  (set! index-nest (+ index-nest 1))
  (set! bracket-end? #f)
  (get-index1))

(define (get-index1)
  (let ((x (parse-formula)))
    (cond (bracket-end? (set! index-nest (- index-nest 1))(list x))
          (else
            (cons x (get-index1))))))


(define (get-symbol x)
  (let ((x2 (get-token)))
    (cond ((operator? x) (unget-token x2) x)
          ((lparen? x2)
           (let ((fn (assv x fn->proc))
                 (tup (get-tuple)))
           (if (not fn)
               (cons x tup)
               (cons (cadr fn) tup))))
          ((lbracket? x2)
           (let ((ls (get-index)))
             (cond ((not (null? ls)) (list 'tensor-ref1 x (cons 'list ls)))
                   (else (sapphire-error "Sapphire: illegal index" ls)))))
          (else
            (unget-token x2)
            (let ((fn (assv x fn->proc)))
              (if (not fn)
                  x
                  (cadr fn)))))))

(define fn->proc
  '((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-tuple)
  (set! tuple-nest (+ tuple-nest 1))
  (let ((x (get-token)))
    (cond ((rparen? x)
           (set! tuple-nest (- tuple-nest 1))
            '())
          (else
            (unget-token x)
            (get-tuple1 '())))))

(define (get-tuple1 ls)
  (let ((x (parse)))
    (cond (paren-end? (reverse (cons x ls)))
          (else
            (get-tuple1 (cons x ls))))))

(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 '^) 'expt)
        ((eqv? x '!) 'fact)
        ((eqv? x '++) 'inc)
        ((eqv? x '--) 'dec)
        ((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 (reserved? x)
  (memv  x '(def if else let fn for while when unless catch throw import)))

(define (semicolon? 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 (sharp? x)
  (cond ((and (char? x)(char=? x #\#))
         (let ((x2 (get-token)))
           (cond ((lbracket? x2) #t)
                 (else (unget-token x2) #f))))
        (else #f)))
               

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

(define (parse-formula)
  (let* ((x (get-term))
         (y (get-token)))
    (cond ((reserved? y) 
           (unget-token y) x)
          ((rcurl? y) 
           (set! curl-end? #t)(unget-token y) x)
          ((semicolon? y) 
           (set! semicolon-end? #t) x)
          ((comma? y)
           (when (and (= begin-nest 0)(= list-nest 0)(= tuple-nest 0)(= index-nest 0))
             (error "Sapphire: illegal comma"))
           (set! comma-end? #t) x)
          ((rparen? y)
           (set! paren-end? #t) x)
          ((rbracket? y) 
           (set! bracket-end? #t) x)
          ((lparen? 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 ((rparen? x)
            (set! paren-end? #t)
            (parse-formula2 operand operator))
           ((comma? x)
            (set! comma-end? #t)
            (parse-formula2 operand operator))
           ((semicolon? x)
            (set! semicolon-end? #t)
            (parse-formula2 operand operator))
           ((rbracket? x)
            (set! bracket-end? #t)
            (parse-formula2 operand operator))
           ((rcurl? x)
            (set! curl-end? #t)
            (unget-token x)(parse-formula2 operand operator))
           ((reserved? x)
            (unget-token x)(parse-formula2 operand operator))
           ((lparen? 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-syntax while
  (syntax-rules ()
    ((_ pred b1 ...)
     (let loop () (if pred (begin b1 ... (loop)))))))
    
(define-syntax for
  (syntax-rules ()
    ((_ (init limit next) b1 ...)
     (begin 
       init
       (let loop()
         (if limit
	        (begin b1 ... next (loop))
            #t))))))
    
(define-syntax catch
  (syntax-rules ()
    ((_ tag body ...)
     (call/cc (lambda (tag) body ...)))))

(define-syntax throw
  (syntax-rules ()
    ((_ tag val)
     (tag val))))

(define-syntax inc
  (syntax-rules ()
    ((_ var) (begin (set! var (+ var 1)) var))))

(define-syntax dec
  (syntax-rules ()
    ((_ var) (begin (set! var (- var 1)) var))))


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


(define (iota s e)
  (if (< s e)
      (iota1 s e)
      (iota2 s e)))

(define (iota1 s e)
  (if (> s e)
      '()
      (cons s (iota1 (+ s 1) e))))

(define (iota2 s e)
  (if (< s e)
      '()
      (cons s (iota2 (- s 1) e))))