etng-r2/evaluator.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 216 aa55f1375161
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
(define-syntax define-global!
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
  (syntax-rules ()
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
    ((_ 'name value) (define name value))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
(define gensym
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
  (let ((counter 14641))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
    (lambda ()
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
      (let ((v (string->symbol (string-append "g" (number->string counter)))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
	(set! counter (+ counter 1))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
	v))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
(define-global! 'global-env
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
  (let ()
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    14
    (define (munge-entry entry) (cons (car entry) (cons (box (cadr entry)) (box (caddr entry)))))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
    (map munge-entry
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    16
	 `((quote macro ,(lambda (x env exp) x))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    17
	   (define macro ,(lambda (x env exp) `(define ,(cadr x) ,@(map exp (cddr x)))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    18
	   (lambda macro ,(lambda (x env exp) `(lambda ,(cadr x) ,@(map exp (cddr x)))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    19
	   (begin macro ,(lambda (x env exp) `(begin ,@(map exp (cdr x)))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    20
	   (if macro ,(lambda (x env exp) `(if ,@(map exp (cdr x)))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    21
	   (set! macro ,(lambda (x env exp) `(set! ,(cadr x) ,(exp (caddr x)))))
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
    22
	   (%assemble macro ,(lambda (x env exp) `(%assemble ,(cadr x) ,(map exp (caddr x))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
    23
						    ,@(cdddr x))))
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    24
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
    25
	   (let macro ,(lambda (x env exp)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
			 (let ((names (map car (cadr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
			       (inits (map cadr (cadr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
			       (exps (cddr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
			   (exp `((lambda ,names ,@exps) ,@inits)))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
	   (cond macro ,(lambda (x env exp)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
			  (exp (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
				((null? (cdr x)) `(begin))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
				((eq? (caadr x) 'else) `(begin ,@(cdadr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
				(else `(if ,(caadr x) (begin ,@(cdadr x)) (cond ,@(cddr x))))))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
	   (case macro ,(lambda (x env exp)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
			  (let ((v (gensym)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
			    (exp `(let ((,v ,(cadr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
				    (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
				     ,@(map (lambda (clause)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
					      (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    41
					       ((eq? (car clause) 'else) clause)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
					       ((null? (cdar clause))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
						`((eq? ,v ',(caar clause)) ,@(cdr clause)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
					       (else (12345678 'multi-case-not-supported clause))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
					    (cddr x))))))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
	   (and macro ,(lambda (x env exp)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
			 (exp (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
			       ((null? (cdr x)) `(begin))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
			       ((null? (cddr x)) (cadr x))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    50
			       (else `(if ,(cadr x) (and ,@(cddr x)) #f))))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
	   (,'quasiquote macro
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
			 ,(lambda (x env exp)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
			    (define (qq exp depth)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
			      (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
			       ((not (pair? exp)) `(quote ,exp))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
			       ((eq? (car exp) 'quasiquote)
193
51d1e29d5e12 Change 'quasiquote to ','quasiquote -- this lets metacircular compilation work
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 192
diff changeset
    57
				`(cons ','quasiquote (cons ,(qq (cadr exp) (+ depth 1)) '())))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
			       ((eq? (car exp) 'unquote)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
				(if (= depth 1)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
				    (cadr exp)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
				    `(cons ','unquote (cons ,(qq (cadr exp) (- depth 1)) '()))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
			       ((and (pair? (car exp))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
				     (eq? (caar exp) 'unquote-splicing))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
				(if (= depth 1)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
				    `(append ,(cadar exp) ,(qq (cdr exp) depth))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
				    `(cons ,(qq (car exp) (- depth 1))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
					   ,(qq (cdr exp) depth))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
			       (else `(cons ,(qq (car exp) depth)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
					    ,(qq (cdr exp) depth)))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
			    (exp (qq (cadr x) 1))))
216
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    71
	   (define-macro macro ,(lambda (x env exp)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    72
				  (let ((name (cadr x))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    73
					(transformer (eval (exp (caddr x)))))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    74
				    (set! global-env (cons (munge-entry
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    75
							    (cons name
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    76
								  (cons 'macro
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    77
									(cons transformer '()))))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    78
							   global-env))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    79
				    `',name)))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    80
	   (define-global! global ,(lambda (arguments k)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    81
				     (let ((name (car arguments))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    82
					   (value (cadr arguments)))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    83
				       ;; FIXME: should set if entry already exists!
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    84
				       (set! global-env (cons (munge-entry
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    85
							       (cons name
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    86
								     (cons 'global
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    87
									   (cons value '()))))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    88
							      global-env))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
    89
				       (k name))))))))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    91
(define-global! 'make-eval
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    92
  (lambda (
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    93
	   error
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    94
	   undefined
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    95
	   allocate-env
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    96
	   update-env
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    97
	   load-env
194
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
    98
	   unbound-variable-read
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
    99
	   load-literal
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   100
	   load-closure
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   101
	   do-if
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   102
	   push-frame
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   103
	   update-frame
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   104
	   do-primitive
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   105
	   do-call
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   106
	   push-continuation
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   107
	   )
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
    (define (env-null? env) (null? env))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   109
    (define (env-name env) (caar env))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   110
    (define (env-annotation env) (unbox (cadar env)))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   111
    (define (env-value env) (unbox (cddar env)))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   112
    (define (set-env-value! env value)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   113
      (set-box! (cadar env) (update-env (env-name env) (env-annotation env) value))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   114
      (set-box! (cddar env) value))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   115
    (define (env-next env) (cdr env))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   116
    (define (make-env name value next)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   117
      (cons (cons name (cons (box (allocate-env name value)) (box value))) next))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   118
    (define (search-one-env env n k fk)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   119
      (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   120
       ((env-null? env) (fk))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   121
       ((eq? (env-name env) n) (k (env-annotation env) (env-value env) env))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   122
       (else (search-one-env (env-next env) n k fk))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   123
    (define (search-env env n k fk)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   124
      (search-one-env env n k (lambda () (search-one-env global-env n k fk))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   125
    (define (expand x env)
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   126
      (define (exp x) (expand x env))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   127
      (if (pair? x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   128
	  (if (symbol? (car x))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   129
	      (search-env env (car x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   130
			  (lambda (annotation v cell) (if (eq? annotation 'macro)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   131
							  (v x env exp)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   132
							  (map exp x)))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   133
			  (lambda () (map exp x)))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   134
	      (map exp x))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   135
	  x))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   136
    (define (make-recursive-env defs env)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
      (if (null? defs)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
	  env
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   139
	  (make-env (caar defs) #f (make-recursive-env (cdr defs) env))))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   140
    (define (e-recursive-definitions defs xs env k)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   141
      (let ((new-env (make-recursive-env defs env)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   142
	(define (fill-init defs pos)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   143
	  (if (null? defs)
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   144
	      (e (cons 'begin xs) new-env k)
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   145
	      (e (cdar defs) new-env
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   146
		 (push-continuation
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   147
		  (lambda (v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   148
		    (set-env-value! pos v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   149
		    (fill-init (cdr defs) (env-next pos)))))))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   150
	(fill-init defs new-env)))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   151
    (define (e-body defs xs env k)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   152
      (if (null? xs)
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   153
	  (e-recursive-definitions defs xs env k)
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   154
	  (let ((x (car xs)))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   155
	    (if (not (pair? x))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   156
		(e-recursive-definitions defs (cons x (cdr xs)) env k)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   157
		(case (car x)
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   158
		  ((begin) (e-body defs (append (cdr x) (cdr xs)) env k))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   159
		  ((define) (if (pair? (cadr x))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   160
				(e-body (cons (cons (caadr x)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   161
						    `(lambda ,(cdadr x) ,@(cddr x)))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   162
					      defs) (cdr xs) env k)
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   163
				(e-body (cons (cons (cadr x) (caddr x)) defs) (cdr xs) env k)))
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   164
		  (else (e-recursive-definitions defs (cons x (cdr xs)) env k)))))))
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   165
    (define (extend-env-with-actuals formals actuals env)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   166
      (if (null? formals)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   167
	  env
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   168
	  (make-env (car formals) (car actuals)
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   169
		    (extend-env-with-actuals (cdr formals) (cdr actuals) env))))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   170
    (define (e-operands index unevaluated evaluated env k)
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   171
      (if (null? unevaluated)
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   172
	  (k (reverse evaluated))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   173
	  (e (car unevaluated) env
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   174
	     (push-continuation
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   175
	      (lambda (newly-evaluated)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   176
		(e-operands (+ index 1)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   177
			    (cdr unevaluated)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   178
			    (cons (update-frame index newly-evaluated) evaluated)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   179
			    env
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   180
			    k))))))
191
f340b63ce5a7 Convert simple scheme-like evaluator to continuation-passing style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 190
diff changeset
   181
    (define (e x env k)
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   182
      (cond
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   183
       ((symbol? x) (search-env env x
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   184
				(lambda (annotation v cell)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   185
				  (if (eq? annotation 'macro)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   186
				      (error 'macro-in-variable-position x)
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   187
				      (k (load-env x annotation v))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   188
				(lambda ()
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   189
				  (k (unbound-variable-read x)))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   190
       ((not (pair? x)) (k (load-literal x)))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   191
       (else
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   192
	(case (car x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   193
	  ((quote) (k (load-literal (cadr x))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   194
	  ((define) (error 'internal-definition-in-invalid-position x))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   195
	  ((lambda) (k (load-closure
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   196
			(cadr x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   197
			(lambda (actuals k)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   198
			  (let ((new-env (extend-env-with-actuals (cadr x) actuals env)))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   199
			    (e-body '() (cddr x) new-env k))))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   200
	  ((begin) (cond ((null? (cdr x)) (k (undefined)))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   201
			 ((null? (cddr x)) (e (cadr x) env k))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   202
			 (else (e (cadr x) env
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   203
				  (push-continuation
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   204
				   (lambda (v)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   205
				     (e (cons 'begin (cddr x)) env k)))))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   206
	  ((if) (e (cadr x) env
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   207
		   (push-continuation
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   208
		    (lambda (v)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   209
		      (do-if v
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   210
			     (lambda () (e (caddr x) env k))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   211
			     (lambda () (e (cadddr x) env k)))))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   212
	  ((set!) (search-env env (cadr x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   213
			      (lambda (annotation v cell)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   214
				(if (eq? annotation 'macro)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   215
				    (error 'macro-in-variable-position x)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   216
				    (e (caddr x) env
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   217
				       (push-continuation
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   218
					(lambda (v)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   219
					  (set-env-value! cell v)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   220
					  (k v))))))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   221
			      (lambda () (error 'unbound-variable x))))
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   222
	  ((%assemble) (e-operands 0 (caddr x) '() env
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   223
				   (push-frame (length (caddr x))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   224
					       (lambda (operands)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   225
						 (do-primitive (cadr x)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   226
							       operands
216
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   227
							       (cdddr x)
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   228
							       k)))))
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   229
	  (else (e-operands 0 (cdr x) '() env
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   230
			    (push-frame (length (cdr x))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   231
					(lambda (operands)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   232
					  (e (car x) env
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   233
					     (push-continuation
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   234
					      (lambda (operator)
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   235
						(do-call operator operands k))))))))))))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   236
    (lambda (x)
197
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   237
      (let ((expanded (expand x '())))
49e38e2ead1d Implement proper expansion-passing-style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 196
diff changeset
   238
	(e expanded '() (lambda (v) v))))))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   239
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   240
(define primitive-eval eval)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   241
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   242
(define-global! 'eval
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   243
  (let ()
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   244
    (define (error key val) (12345678 'magic-error-procedure key val))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   245
    (define (undefined) 17)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   246
    (define (allocate-env name v) 'local)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   247
    (define (update-env name old-annotation v) old-annotation)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   248
    (define (load-env name annotation v) v)
194
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   249
    (define (unbound-variable-read x) (error 'unbound-variable-read x))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   250
    (define (load-literal x) x)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   251
    (define (load-closure formals f) f)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   252
    (define (do-if v tk fk) (if v (tk) (fk)))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   253
    (define (push-frame count k) k)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   254
    (define (update-frame index v) v)
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   255
    (define (do-primitive names vals expressions k)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   256
      (define (search expressions)
216
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   257
	;;(write `(do-primitive:search ,names ,vals ,expressions)) (newline)
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   258
	(cond
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   259
	 ((null? expressions)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   260
	  (error 'missing-scheme-assembly-expression `(%assemble ,names ,vals ,@expressions)))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   261
	 ((eq? (caar expressions) 'scheme)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   262
	  (k ((primitive-eval `(lambda (actuals) (apply (lambda ,names ,@(cdar expressions))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   263
							actuals)))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   264
	      vals)))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   265
	 (else (search (cdr expressions)))))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   266
      (search expressions))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   267
    (define (do-call operator operands k) (operator operands k))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   268
    (define (push-continuation k) k)
194
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   269
    (make-eval error undefined allocate-env update-env load-env unbound-variable-read
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   270
	       load-literal load-closure do-if push-frame update-frame
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   271
	       do-primitive do-call push-continuation)))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   272
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   273
(define-global! 'compile
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   274
  (lambda (exp)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   275
    (let ((continuation-depth (make-parameter 0)))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   276
      (define (error key val) (12345678 'magic-error-procedure key val))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   277
      (define (undefined) (load-literal 17))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   278
      (define (allocate-env name v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   279
	(write `(allocate-env ,name ,v)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   280
	'local)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   281
      (define (update-env name old-annotation v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   282
	(write `(update-env ,name ,old-annotation)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   283
	old-annotation)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   284
      (define (load-env name annotation v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   285
	(write `(load-env ,name ,annotation)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   286
	v)
194
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   287
      (define (unbound-variable-read name)
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   288
	(write `(load-implicit-global ,name)) (newline)
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   289
	'implicit-global-value)
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   290
      (define (load-literal x)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   291
	(write `(load-literal ,x)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   292
	x)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   293
      (define (load-closure formals f)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   294
	(write `(load-closure ,formals)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   295
	(parameterize ((continuation-depth 0))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   296
	  (write `(IN================)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   297
	  (f formals (lambda (v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   298
		       (write `(return)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   299
		       v))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   300
	  (write `(OUT===============)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   301
	  'closure-result))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   302
      (define (do-if v tk fk)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   303
	(write `(do-if ,v)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   304
	(write `tk) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   305
	(tk)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   306
	(write `fk) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   307
	(fk))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   308
      (define (push-frame count k)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   309
	(write `(push-frame ,count)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   310
	k)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   311
      (define (update-frame index v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   312
	(write `(update-frame ,index ,v)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   313
	v)
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   314
      (define (do-primitive names vals expressions k)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   315
	(write `(%assemble ,names ,vals ,expressions))
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   316
	(k 'primitive-result))
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   317
      (define (do-call operator operands k)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   318
	(write `(do-call ,(if (= (continuation-depth) 0)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   319
			      'tailcall
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   320
			      'normalcall) ,operator ,operands))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   321
	(newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   322
	(k 'do-call-result))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   323
      (define (push-continuation k)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   324
	;;(write `(push-continuation)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   325
	(continuation-depth (+ (continuation-depth) 1))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   326
	(lambda (v)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   327
	  ;;(write `(pop-continuation ,v)) (newline)
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   328
	  (continuation-depth (- (continuation-depth) 1))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   329
	  (k v)))
194
84461d0a5c25 Add a hook for an unbound global reference, to permit compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 193
diff changeset
   330
      ((make-eval error undefined allocate-env update-env load-env unbound-variable-read
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   331
		  load-literal load-closure do-if push-frame update-frame
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   332
		  do-primitive do-call push-continuation)
192
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   333
       exp))))
c5a04feea230 Prepare for conversion to a partial-evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 191
diff changeset
   334
216
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   335
(define (read-file filename)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   336
  (call-with-input-file filename
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   337
    (lambda (handle)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   338
      (let loop ()
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   339
	(let ((sexp (read handle)))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   340
	  (if (eof-object? sexp)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   341
	      '()
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   342
	      (cons sexp (loop))))))))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   343
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   344
(define-global! 'base-load*
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   345
  (lambda (filename evaluator)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   346
    (for-each evaluator (read-file filename))))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   347
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   348
(define-global! 'base-load
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   349
  (lambda (filename)
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   350
    (base-load* filename eval)))
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   351
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   352
(base-load "evaluator-base-library.scm")
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   353
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   354
(define (syms x)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   355
  (cond
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   356
   ((pair? x) (syms (car x)) (syms (cdr x)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   357
   ((null? x))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   358
   (else (write x) (newline))))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   359
195
eacc4e318dae Make (r) into (r* repl-eval), to permit (r* compile).
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 194
diff changeset
   360
(define (r* repl-eval)
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   361
  (display ">>> ")
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   362
  (let ((x (read)))
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   363
    (if (eof-object? x)
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   364
	'done
195
eacc4e318dae Make (r) into (r* repl-eval), to permit (r* compile).
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 194
diff changeset
   365
	(begin (write (repl-eval x))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   366
	       (newline)
195
eacc4e318dae Make (r) into (r* repl-eval), to permit (r* compile).
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 194
diff changeset
   367
	       (r* repl-eval)))))
eacc4e318dae Make (r) into (r* repl-eval), to permit (r* compile).
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 194
diff changeset
   368
eacc4e318dae Make (r) into (r* repl-eval), to permit (r* compile).
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 194
diff changeset
   369
(define (r) (r* eval))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   370
216
aa55f1375161 Switch to using %assemble for primitives.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 214
diff changeset
   371
;;(eval `(define-global! 'global-env ',global-env))
190
903b8ad8b6f1 Self-hostable scheme-like evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   372
(r)
213
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   373
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   374
;;; Local Variables:
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   375
;;; eval: (put '%assemble 'scheme-indent-function 2)
660693d22b19 Add %assemble primitive.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 197
diff changeset
   376
;;; End: