r2/evaltng.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 31 471898c6b52e
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
'(tng-cst-grammar
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
  (<datum> (or (<value>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
	       (tuple <value> ...)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
  (<value> (or (atom <symbol>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
	       (var <symbol>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
	       (lit <literal>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
	       (adj <value> <value>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
	       (fun (<value> <value>) ...)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
	       (quote <value>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
	       (meta-quote <value>)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
	       (discard)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
  (<literal> (or (<integer>))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
(define-record-type tng-promise
29
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    15
  (make-tng-promise* id defined? value)
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
  tng-promise?
29
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    17
  (id tng-promise-id)
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
  (defined? tng-promise-defined? set-tng-promise-defined?!)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
  (value tng-promise-value set-tng-promise-value!))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
(define-record-type tng-closure
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
  (make-tng-closure clauses outer-env)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
  tng-closure?
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
  (clauses tng-closure-clauses)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
  (outer-env tng-closure-outer-env))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
(define-record-printer (tng-promise p out)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
  (for-each (cut display <> out)
29
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    29
	    (list "#<tng-promise "(tng-promise-id p)" "(tng-promise-defined? p)" "(tng-promise-value p)">")))
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    30
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    31
(define make-promise-id
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    32
  (let ((counter 0))
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    33
    (lambda ()
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    34
      (let ((val counter))
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    35
	(set! counter (+ counter 1))
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    36
	val))))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
(define-syntax tng
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
  (syntax-rules ()
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
    ((_ interp arg ...)
29
86ab7bec3027 Add unique identifier to promises, for debugging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
    41
     (make-tng-promise* (make-promise-id) #f (list interp arg ...)))))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
(define (force-tng t)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
  (if (tng-promise? t)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
      (if (tng-promise-defined? t)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
	  (tng-promise-value t)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
	  (let ((closure (tng-promise-value t)))
30
e9c2c0933929 Recursively force, since there are situations where we can promise a promise.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
    48
	    ;; I am unsure about this recursive force call! Can't things be arranged
e9c2c0933929 Recursively force, since there are situations where we can promise a promise.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
    49
	    ;; so that we never promise a promise? %%%
e9c2c0933929 Recursively force, since there are situations where we can promise a promise.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
    50
	    (let ((v (force-tng (apply (car closure) (map force-tng (cdr closure))))))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
	      (set-tng-promise-defined?! t #t)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
	      (set-tng-promise-value! t v)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
	      v)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
      t))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
(define (eval-error . x) (apply error x))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    57
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
(define (quote-layer forced-term env)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
  (case (car forced-term)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
    ((tuple) `(tuple ,@(map (cut eval-ThiNG <> env) (cdr forced-term))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
    ((atom) forced-term)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
    ((lit) forced-term)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
    ((adj) `(adj ,(eval-ThiNG (cadr forced-term) env)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
		 ,(tng quote-layer (caddr forced-term) env)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
    ((fun) (make-tng-closure (cdr forced-term) env))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
    ((var quote meta-quote discard)
23
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
    67
     (eval-error "quote-layer: pointless quoting" forced-term env))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
    (else
23
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
    69
     (eval-error "quote-layer: unknown term" forced-term env))))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    71
(define (match-quoted p v b)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    72
  (case (car p)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    73
    ((atom var lit discard) (match-one p v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    74
    ((quote) (eval-error "match-quoted: pointless quoting" p v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    75
    ((meta-quote) (eval-error "meta-quote unimplemented (in match-quoted)" p v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    76
    (else
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    77
     (let ((vv (force-tng v)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    78
       (case (car p)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    79
	 ((tuple) (and (eq? (car vv) 'tuple)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    80
		       (let match-each ((ps (cdr p))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
					(vs (cdr vv))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
					(b b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
			 (if (null? ps)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
			     (and (null? vs) b)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
			     (and (not (null? vs))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
				  (let ((b1 (match-one (car ps) (car vs) b)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
				    (and b1 (match-each (cdr ps) (cdr vs) b1))))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
	 ((adj) (and (eq? (car vv) 'adj)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
		     (and-let* ((b1 (match-one (cadr p) (cadr vv) b)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
		       (match-quoted (caddr p) (caddr vv) b1))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    91
	 ;; Variables alternate roles when quoted, and the roles are
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    92
	 ;; flipped in pattern context when compared to value context.
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    93
	 ;;
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    94
	 ;; In a pattern, a variable is a binding occurrence unless
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    95
	 ;; it's in a quoted-subpattern, in which case it's a
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    96
	 ;; referencing occurrence; In a value, a variable is a
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    97
	 ;; referencing occurrence unless it's in a quoted-subvalue,
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    98
	 ;; in which case it's a binding occurrence.
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    99
	 ;;
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   100
	 ;; %%% FIXME: get the scoping right for references in
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   101
	 ;; quoted-subpatterns.
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   102
	 ;;
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   103
	 ((fun) (and (tng-closure? vv)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   104
		     (let ((env b)) ;; see FIXME above
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   105
		       (let match-each ((clauses (cdr p))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   106
					(b b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   107
			 (if (null? clauses)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
			     b
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   109
			     (let ((pv (caar clauses))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   110
				   (pp (cadar clauses)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   111
			       (eval-app vv
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   112
					 pv
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   113
					 env
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   114
					 (lambda (code new-env)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   115
					   (let ((result (eval-ThiNG code new-env)))
22
413964ae5c5f I really need to sort out this notion of when things are quoted.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 20
diff changeset
   116
					     (and-let* ((b1 (match-one pp result b)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   117
					       (match-each (cdr clauses) b1))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   118
					 (lambda ()
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   119
					   #f))))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   120
	 (else (eval-error "match-quoted: unknown term" p vv b)))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   121
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   122
(define (match-one p v b)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   123
  (case (car p)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   124
    ((var) (cons (cons (cadr p) v) b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   125
    ((quote) (match-quoted (cadr p) v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   126
    ((meta-quote) (eval-error "meta-quote unimplemented (in match-one)" p v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   127
    ((discard) b)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   128
    ((adj tuple fun) (eval-error "match-one: missing quoting" p v b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   129
    (else
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   130
     (let ((vv (force-tng v)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   131
       (case (car p)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   132
	 ((atom) (and (eq? (car vv) 'atom)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   133
		      (eq? (cadr p) (cadr vv))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   134
		      b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   135
	 ((lit) (and (eq? (car vv) 'lit)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   136
		     (equal? (cadr p) (cadr vv))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
		     b))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
	 (else (eval-error "match-one: unknown term" p vv b)))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   139
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   140
(define (match-clause clauses arg outer-env sk fk)
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   141
  (let search ((clauses clauses))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   142
    (if (null? clauses)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   143
	(fk)
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   144
	(let ((new-env (match-one (caar clauses) arg outer-env)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   145
	  (if new-env
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   146
	      (sk (cadar clauses) new-env)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   147
	      (search (cdr clauses)))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   148
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   149
(define (eval-app fn arg env sk fk)
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   150
  (let ((fn (force-tng fn)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   151
    (if (tng-closure? fn)
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   152
	(let* ((arg (eval-ThiNG arg env)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   153
	  (match-clause (tng-closure-clauses fn)
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   154
			arg
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   155
			(tng-closure-outer-env fn)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   156
			sk
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   157
			fk))
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   158
	(eval-error "eval-app: attempt to apply non-function" fn arg env))))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   159
23
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   160
(define (eval-ThiNG-inner term env)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   161
  (case (car term)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   162
    ((tuple) ;; Parallel evaluation? sigh
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   163
     `(tuple ,@(map (cut eval-ThiNG <> env) (cdr term))))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   164
    ((atom) term)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   165
    ((var) (cond
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   166
	    ((assq (cadr term) env) => cdr)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   167
	    (else (eval-error "Unbound variable" term env))))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   168
    ((lit) term)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   169
    ((adj) (eval-app (eval-ThiNG (cadr term) env)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   170
		     (caddr term)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   171
		     env
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   172
		     eval-ThiNG
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   173
		     (lambda ()
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   174
		       (eval-error "no match found" term env))))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   175
    ((fun) (eval-error "Situations unimplemented" term env))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   176
    ((quote) (if #f ;; disable quoting through one layer of tupling
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   177
		 (let ((v (force-tng (cadr term))))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   178
		   (if (eq? (car v) 'tuple)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   179
		       `(tuple ,@(map (lambda (x) (tng quote-layer x env)) (cdr v)))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   180
		       (quote-layer v env)))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   181
		 (quote-layer (force-tng (cadr term)) env)))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   182
    ((meta-quote) (eval-error "meta-quote unimplemented" term env))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   183
    ((discard) (eval-error "Discard appeared on the right" term env))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   184
    (else (eval-error "Unknown term" term env))))
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   185
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   186
(define (eval-ThiNG term env)
ca4c9dac5625 Remove now-redundant parentheses.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 22
diff changeset
   187
  (tng eval-ThiNG-inner term env))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   188
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   189
(define (call-with-stupid-error-handler f)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   190
  (call-with-current-continuation
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   191
   (lambda (escape)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   192
     (fluid-let ((error (lambda x (escape `(ERROR ,@x)))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   193
       (f)))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   194
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   195
(define (pretty-print-ThiNG x)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   196
  (let ((x (call-with-stupid-error-handler
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   197
	    (lambda ()
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   198
	      (let walk ((x x))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   199
		(cond
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   200
		 ((pair? x) (cons (walk (car x))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   201
				  (walk (cdr x))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   202
		 ((tng-closure? x) `(fun-closure ,(tng-closure-clauses x)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   203
						 ,(walk (tng-closure-outer-env x))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   204
		 ((tng-promise? x) (walk (force-tng x)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   205
		 (else x)))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   206
    (pretty-print x)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   207
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   208
(define (repl-ThiNG)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   209
  (display ">>>ThiNG>>> ")
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   210
  (let ((x (call-with-stupid-error-handler read-ThiNG)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   211
    (newline)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   212
    (pretty-print x)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   213
    (newline)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   214
    (if (eq? (car x) 'ERROR)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   215
	(repl-ThiNG)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   216
	(if (not (equal? x '(atom Quit)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   217
	    (let ((r (call-with-stupid-error-handler (lambda () (eval-ThiNG x '())))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   218
	      (pretty-print-ThiNG r)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   219
	      (newline)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   220
	      (repl-ThiNG))))))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   221
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   222
;(trace match-one)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   223
;(trace match-quoted)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   224
;(trace match-clause)
31
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   225
;(trace force-tng)
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   226
;(trace eval-app)
471898c6b52e Simplify application, to match simplified grammar definition for adj.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 30
diff changeset
   227
;(trace eval-ThiNG-inner)