Extend Scheme reader, reduce C reader dependency.
[mes.git] / module / mes / read-0.mes
index f36fff67f3fe0fd8802e0121f447151aa7aed7e7..8d59bb178d89cfd2277238eb1692d77e7cce1cc4 100644 (file)
   ;; * read characters, quote, strings
 
   (define (read)
-    (read-word (read-byte) '() (current-module)))
+    (read-word (read-byte) (list) (current-module)))
+
+  (define (read-env a)
+    (read-word (read-byte) (list) a))
 
   (define (read-input-file)
     (define (helper x)
     (helper (read)))
 
   (define-macro (cond . clauses)
-    (list 'if (null? clauses) *unspecified*
+    (list (quote if) (null? clauses) *unspecified*
           (if (null? (cdr clauses))
-              (list 'if (car (car clauses))
-                    (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
+              (list (quote if) (car (car clauses))
+                    (list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))
                     *unspecified*)
-              (if (eq? (car (cadr clauses)) 'else)
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (cons 'cond (cdr clauses)))))))
+              (if (eq? (car (cadr clauses)) (quote else))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (cons (quote cond) (cdr clauses)))))))
 
   (define (eat-whitespace)
     (cond
 
   (define (read-list a)
     (eat-whitespace)
-    (if (eq? (peek-byte) 41) (begin (read-byte) '())
+    (if (eq? (peek-byte) 41) (begin (read-byte) (list))
         ((lambda (w)
-           (if (eq? w '.) (car (read-list a))
+           (if (eq? w *dot*) (car (read-list a))
                (cons w (read-list a))))
-         (read-word (read-byte) '() a))))
+         (read-word (read-byte) (list) a))))
 
   ;;(define (read-string))
 
   (define (lookup-char c a)
-    (lookup (cons (integer->char c) '()) a))
+    (lookup (cons (integer->char c) (list)) a))
 
   (define (read-word c w a)
     (cond
-      ((eq? c -1) '())
-      ((eq? c 10) (if (null? w) (read-word (read-byte) '() a)
+      ((eq? c -1) (list))
+      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)
                       (lookup w a)))
       ((eq? c 32) (read-word 10 w a))
       ((eq? c 34) (if (null? w) (read-string)
                    ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
                    ((eq? (peek-byte) 92) (read-byte) (read-character))
                    ((eq? (peek-byte) 120) (read-byte) (read-hex))
-                   (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
-      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+                   ((eq? (peek-byte) 44)
+                    (read-byte)
+                    (cond ((eq? (peek-byte) 64)
+                           (read-byte)
+                           (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
+                                 (cons (read-word (read-byte) w a) (list))))
+                          (else
+                           (cons (lookup (symbol->list (quote unsyntax)) a)
+                                 (cons (read-word (read-byte) w a) (list))))))
+                   ((eq? (peek-byte) 39) (read-byte)
+                    (cons (lookup (cons (integer->char 35) (cons (integer->char 39) (list))) a)
+                          (cons (read-word (read-byte) w a) (list))))
+                   ((eq? (peek-byte) 96) (read-byte)
+                    (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
+                          (cons (read-word (read-byte) w a) (list))))
+                   (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (cons (read-word (read-byte) w a) (list)))
                       (begin (unread-byte c) (lookup w a))))
       ((eq? c 40) (if (null? w) (read-list a)
                       (begin (unread-byte c) (lookup w a))))
-      ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+      ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (cons (read-word (read-byte) w a) (list)))
                       (begin (unread-byte c) (lookup w a))))
       ((eq? c 44) (cond
                    ((eq? (peek-byte) 64) (begin (read-byte)
                                                 (cons
-                                                 (lookup (symbol->list 'unquote-splicing) a)
-                                                 (cons (read-word (read-byte) w a) '()))))
+                                                 (lookup (symbol->list (quote unquote-splicing)) a)
+                                                 (cons (read-word (read-byte) w a) (list)))))
                    (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)
-                                                        '())))))
-      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) '())))
+                                                        (list))))))
+      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
-      (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
+      (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
 
   ((lambda (p)
-     ;;(display 'program=) (display p) (newline)
+     ;;(display (quote scheme-program=)) (display p) (newline)
      (begin-env p (current-module)))
    (read-input-file)))