Move optional type predicates to type.c.
[mes.git] / module / mes / loop-0.mes
index dd406984933e1712ad8c8a1e3555dced9d39f521..6fbf654cb52b5fc14862ab7cbec2f11f3d7d8a6e 100644 (file)
 ()
 ;; enter reading loop-0
 (display "loop-0 ...\n")
-
-(define-macro (cond . clauses)
-  (list 'if (null? clauses) *unspecified*
-        (if (null? (cdr clauses))
-            (list 'if (car (car clauses))
-                  (list (cons 'lambda (cons '() (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)))))))
-
-(define (map f l . r)
-  (if (null? l) '()
-      (if (null? r) (cons (f (car l)) (map f (cdr l)))
-          (if (null? (cdr r))
-              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
-
-(define-macro (simple-let bindings . rest)
-  (cons (cons 'lambda (cons (map car bindings) rest))
-        (map cadr bindings)))
-
-(define-macro (let bindings . rest)
-  (cons 'simple-let (cons bindings rest)))
-
-(define-macro (or . x)
-  (if (null? x) #f
-      (if (null? (cdr x)) (car x)
-          (list 'if (car x) (car x)
-                (cons 'or (cdr x))))))
-
-(define-macro (and . x)
-  (if (null? x) #t
-      (if (null? (cdr x)) (car x)
-          (list 'if (car x) (cons 'and (cdr x))
-                #f))))
-
-(define (not x)
-  (if x #f #t))
-
-(define (evlis-env m a)
-  (cond
-   ((null? m) '())
-   ((not (pair? m)) (eval m a))
-   (#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
-
-(define (apply-env fn x a) 
-  (cond
-   ((atom? fn)
-    (cond
-     ((builtin? fn) (call fn x))
-     ((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
-     ((eq? fn 'current-module) a)
-     (#t (apply-env (eval fn a) x a))))
-   ((eq? (car fn) 'lambda)
-    (let ((p (pairlis (cadr fn) x a)))
-      (cache-invalidate-range p (cdr a))
-      (let ((r (eval (cons 'begin (cddr fn)) (cons (cons '*closure* p) p))))
-        (cache-invalidate-range p (cdr a))
-        r)))
-   ((eq? (car fn) '*closure*)
-    (let ((args (caddr fn))
-          (body (cdddr fn))
-          (a (cddr (cadr fn))))
-      (let ((p (pairlis args x a)))
-        (cache-invalidate-range p (cdr a))
-        (let ((r (eval (cons 'begin body) (cons (cons '*closure* p) p))))
-          (cache-invalidate-range p (cdr a))
-          r))))
-   ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
-   (#t (apply-env (eval fn a) x a))))
-
-(define (eval-expand e a)
-  (cond
-   ((internal? e) e)
-   ((builtin? e) e)
-   ((char? e) e)
-   ((number? e) e)
-   ((string? e) e)
-   ((vector? e) e)
-   ((symbol? e) (assq-ref-cache e a))
-   ((atom? (car e))
-    (cond
-     ((eq? (car e) 'quote) (cadr e))
-     ((eq? (car e) 'syntax) (cadr e))
-     ((eq? (car e) 'begin) (eval-begin-env e a))
-     ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
-     ((eq? (car e) '*closure*) e)
-     ((eq? (car e) 'if) (eval-if-env (cdr e) a))
-     ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
-     ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
-     ((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
-     ((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a))
-     ((eq? (car e) 'unquote) (eval (cadr e) a))
-     ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
-     (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
-   (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
-
-(define (unquote x) (cons 'unquote x))
-(define (unquote-splicing x) (cons 'quasiquote x))
-
-(define (add-unquoters a)
-  (cons (cons 'unquote unquote)
-        (cons (cons 'unquote-splicing unquote-splicing) a)))
-
-(define (eval e a)
-  (eval-expand (expand-macro-env e a) a))
-
-(define (expand-macro-env e a)
-  (if (pair? e) ((lambda (macro)
-                   (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
-                       e))
-                 (lookup-macro (car e) a))
-      e))
-
-(define (eval-begin-env e a)
-  (if (null? e) *unspecified*
-      (if (null? (cdr e)) (eval (car e) a)
-          (begin
-            (eval (car e) a)
-            (eval-begin-env (cdr e) a)))))
-
-(define (eval-if-env e a)
-  (if (eval (car e) a) (eval (cadr e) a)
-      (if (pair? (cddr e)) (eval (caddr e) a))))
-
-(define (eval-quasiquote e a)
-  (cond ((null? e) e)
-        ((atom? e) e)
-        ((eq? (car e) 'unquote) (eval (cadr e) a))
-        ((and (pair? (car e))
-              (eq? (caar e) 'unquote-splicing))
-         (append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
-        (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
-
-(define (sexp:define e a)
-  (if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
-      (cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
-
-(define (env:define a+ a)
-  (set-cdr! a+ (cdr a))
-  (set-cdr! a a+)
-  (set-cdr! (assq '*closure* a) a))
-
-(define (env:macro name+entry)
-  (cons
-   (cons (car name+entry)
-         (make-macro (car name+entry)
-                     (cdr name+entry)))
-   '()))
-
-;; boot into loop-0
-(cache-invalidate-range (current-module) '())
-()
-ignored