andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Revert "comment-out COND" 

This reverts commit 0d799d85f69730340c6ef827e553e0a0bfc11c22.
This commit is contained in:
Jan Nieuwenhuizen 2016-10-29 09:38:18 +02:00
parent 091203b3d0
commit fce7824d8f
1 changed files with 92 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
module/mes/mes-0.mes
View File

@ -34,84 +34,84 @@
;;; Code:
;; (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-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 (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 (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 (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 (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-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-expand m a))
;; (#t (cons (eval-expand (car m) a) (evlis-env (cdr m) a)))))
(define (evlis-env m a)
(cond
((null? m) '())
((not (pair? m)) (eval-expand m a))
(#t (cons (eval-expand (car m) a) (evlis-env (cdr m) a)))))
(define (evlis-env m a)
(if (null? m) '()
(if (not (pair? m)) (eval m a)
(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-expand fn a) x a))))
;; ((eq? (car fn) 'lambda)
;; (let ((p (pairlis (cadr fn) x a)))
;; (cache-invalidate-range p (cdr a))
;; (let ((r (eval-begin-env (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-begin-env 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-expand fn a) x 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-expand fn a) x a))))
((eq? (car fn) 'lambda)
(let ((p (pairlis (cadr fn) x a)))
(cache-invalidate-range p (cdr a))
(let ((r (eval-begin-env (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-begin-env 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-expand fn a) x a))))
(define (apply-env fn x a)
(if (atom? fn) (if (builtin? fn) (call fn x)
@ -153,27 +153,27 @@
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
(apply-env (eval fn a) x a)))))
;; (define (eval-expand e a)
;; (display "mes:eval-expand e=") (display e) (newline)
;; (cond
;; ((symbol? e) (assq-ref-cache e a))
;; ((atom? e) e)
;; ((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-expand (caddr e) a) a))
;; ((eq? (car e) 'apply-env) (apply-env (eval-expand (cadr e) a) (evlis-env (caddr e) a) a))
;; ((eq? (car e) 'unquote) (eval-expand (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 (eval-expand e a)
(display "mes:eval-expand e=") (display e) (newline)
(cond
((symbol? e) (assq-ref-cache e a))
((atom? e) e)
((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-expand (caddr e) a) a))
((eq? (car e) 'apply-env) (apply-env (eval-expand (cadr e) a) (evlis-env (caddr e) a) a))
((eq? (car e) 'unquote) (eval-expand (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 (eval-expand e a)
(if (symbol? e) (assq-ref-cache e a)
@ -227,14 +227,14 @@
(if (eval-expand (car e) a) (eval-expand (cadr e) a)
(if (pair? (cddr e)) (eval-expand (caddr e) a))))
;; (define (eval-quasiquote e a)
;; (cond ((null? e) e)
;; ((atom? e) e)
;; ((eq? (car e) 'unquote) (eval-expand (cadr e) a))
;; ((and (pair? (car e))
;; (eq? (caar e) 'unquote-splicing))
;; (append2 (eval-expand (cadar e) a) (eval-quasiquote (cdr e) a)))
;; (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
(define (eval-quasiquote e a)
(cond ((null? e) e)
((atom? e) e)
((eq? (car e) 'unquote) (eval-expand (cadr e) a))
((and (pair? (car e))
(eq? (caar e) 'unquote-splicing))
(append2 (eval-expand (cadar e) a) (eval-quasiquote (cdr e) a)))
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
(define (eval-quasiquote e a)
(if (null? e) e