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.

  (<datum> (or (<value>)
	       (tuple <value> ...)))
  (<value> (or (atom <symbol>)
	       (var <symbol>)
	       (lit <literal>)
	       (adj <value> <value>)
	       (fun (<value> <value>) ...)
	       (quote <value>)
	       (meta-quote <value>)
  (<literal> (or (<integer>))))

(define-record-type tng-promise
  (make-tng-promise* id defined? value)
  (id tng-promise-id)
  (defined? tng-promise-defined? set-tng-promise-defined?!)
  (value tng-promise-value set-tng-promise-value!))

(define-record-type tng-closure
  (make-tng-closure clauses outer-env)
  (clauses tng-closure-clauses)
  (outer-env tng-closure-outer-env))

(define-record-printer (tng-promise p out)
  (for-each (cut display <> out)
	    (list "#<tng-promise "(tng-promise-id p)" "(tng-promise-defined? p)" "(tng-promise-value p)">")))

(define make-promise-id
  (let ((counter 0))
    (lambda ()
      (let ((val counter))
	(set! counter (+ counter 1))

(define-syntax tng
  (syntax-rules ()
    ((_ interp arg ...)
     (make-tng-promise* (make-promise-id) #f (list interp arg ...)))))

(define (force-tng t)
  (if (tng-promise? t)
      (if (tng-promise-defined? t)
	  (tng-promise-value t)
	  (let ((closure (tng-promise-value t)))
	    ;; I am unsure about this recursive force call! Can't things be arranged
	    ;; so that we never promise a promise? %%%
	    (let ((v (force-tng (apply (car closure) (map force-tng (cdr closure))))))
	      (set-tng-promise-defined?! t #t)
	      (set-tng-promise-value! t v)

(define (eval-error . x) (apply error x))

(define (quote-layer forced-term env)
  (case (car forced-term)
    ((tuple) `(tuple ,@(map (cut eval-ThiNG <> env) (cdr forced-term))))
    ((atom) forced-term)
    ((lit) forced-term)
    ((adj) `(adj ,(eval-ThiNG (cadr forced-term) env)
		 ,(tng quote-layer (caddr forced-term) env)))
    ((fun) (make-tng-closure (cdr forced-term) env))
    ((var quote meta-quote discard)
     (eval-error "quote-layer: pointless quoting" forced-term env))
     (eval-error "quote-layer: unknown term" forced-term env))))

(define (match-quoted p v b)
  (case (car p)
    ((atom var lit discard) (match-one p v b))
    ((quote) (eval-error "match-quoted: pointless quoting" p v b))
    ((meta-quote) (eval-error "meta-quote unimplemented (in match-quoted)" p v b))
     (let ((vv (force-tng v)))
       (case (car p)
	 ((tuple) (and (eq? (car vv) 'tuple)
		       (let match-each ((ps (cdr p))
					(vs (cdr vv))
					(b b))
			 (if (null? ps)
			     (and (null? vs) b)
			     (and (not (null? vs))
				  (let ((b1 (match-one (car ps) (car vs) b)))
				    (and b1 (match-each (cdr ps) (cdr vs) b1))))))))
	 ((adj) (and (eq? (car vv) 'adj)
		     (and-let* ((b1 (match-one (cadr p) (cadr vv) b)))
		       (match-quoted (caddr p) (caddr vv) b1))))
	 ;; Variables alternate roles when quoted, and the roles are
	 ;; flipped in pattern context when compared to value context.
	 ;; In a pattern, a variable is a binding occurrence unless
	 ;; it's in a quoted-subpattern, in which case it's a
	 ;; referencing occurrence; In a value, a variable is a
	 ;; referencing occurrence unless it's in a quoted-subvalue,
	 ;; in which case it's a binding occurrence.
	 ;; %%% FIXME: get the scoping right for references in
	 ;; quoted-subpatterns.
	 ((fun) (and (tng-closure? vv)
		     (let ((env b)) ;; see FIXME above
		       (let match-each ((clauses (cdr p))
					(b b))
			 (if (null? clauses)
			     (let ((pv (caar clauses))
				   (pp (cadar clauses)))
			       (eval-app vv
					 (lambda (code new-env)
					   (let ((result (eval-ThiNG code new-env)))
					     (and-let* ((b1 (match-one pp result b)))
					       (match-each (cdr clauses) b1))))
					 (lambda ()
	 (else (eval-error "match-quoted: unknown term" p vv b)))))))

(define (match-one p v b)
  (case (car p)
    ((var) (cons (cons (cadr p) v) b))
    ((quote) (match-quoted (cadr p) v b))
    ((meta-quote) (eval-error "meta-quote unimplemented (in match-one)" p v b))
    ((discard) b)
    ((adj tuple fun) (eval-error "match-one: missing quoting" p v b))
     (let ((vv (force-tng v)))
       (case (car p)
	 ((atom) (and (eq? (car vv) 'atom)
		      (eq? (cadr p) (cadr vv))
	 ((lit) (and (eq? (car vv) 'lit)
		     (equal? (cadr p) (cadr vv))
	 (else (eval-error "match-one: unknown term" p vv b)))))))

(define (match-clause clauses arg outer-env sk fk)
  (let search ((clauses clauses))
    (if (null? clauses)
	(let ((new-env (match-one (caar clauses) arg outer-env)))
	  (if new-env
	      (sk (cadar clauses) new-env)
	      (search (cdr clauses)))))))

(define (eval-app fn arg env sk fk)
  (let ((fn (force-tng fn)))
    (if (tng-closure? fn)
	(let* ((arg (eval-ThiNG arg env)))
	  (match-clause (tng-closure-clauses fn)
			(tng-closure-outer-env fn)
	(eval-error "eval-app: attempt to apply non-function" fn arg env))))

(define (eval-ThiNG-inner term env)
  (case (car term)
    ((tuple) ;; Parallel evaluation? sigh
     `(tuple ,@(map (cut eval-ThiNG <> env) (cdr term))))
    ((atom) term)
    ((var) (cond
	    ((assq (cadr term) env) => cdr)
	    (else (eval-error "Unbound variable" term env))))
    ((lit) term)
    ((adj) (eval-app (eval-ThiNG (cadr term) env)
		     (caddr term)
		     (lambda ()
		       (eval-error "no match found" term env))))
    ((fun) (eval-error "Situations unimplemented" term env))
    ((quote) (if #f ;; disable quoting through one layer of tupling
		 (let ((v (force-tng (cadr term))))
		   (if (eq? (car v) 'tuple)
		       `(tuple ,@(map (lambda (x) (tng quote-layer x env)) (cdr v)))
		       (quote-layer v env)))
		 (quote-layer (force-tng (cadr term)) env)))
    ((meta-quote) (eval-error "meta-quote unimplemented" term env))
    ((discard) (eval-error "Discard appeared on the right" term env))
    (else (eval-error "Unknown term" term env))))

(define (eval-ThiNG term env)
  (tng eval-ThiNG-inner term env))

(define (call-with-stupid-error-handler f)
   (lambda (escape)
     (fluid-let ((error (lambda x (escape `(ERROR ,@x)))))

(define (pretty-print-ThiNG x)
  (let ((x (call-with-stupid-error-handler
	    (lambda ()
	      (let walk ((x x))
		 ((pair? x) (cons (walk (car x))
				  (walk (cdr x))))
		 ((tng-closure? x) `(fun-closure ,(tng-closure-clauses x)
						 ,(walk (tng-closure-outer-env x))))
		 ((tng-promise? x) (walk (force-tng x)))
		 (else x)))))))
    (pretty-print x)))

(define (repl-ThiNG)
  (display ">>>ThiNG>>> ")
  (let ((x (call-with-stupid-error-handler read-ThiNG)))
    (pretty-print x)
    (if (eq? (car x) 'ERROR)
	(if (not (equal? x '(atom Quit)))
	    (let ((r (call-with-stupid-error-handler (lambda () (eval-ThiNG x '())))))
	      (pretty-print-ThiNG r)

;(trace match-one)
;(trace match-quoted)
;(trace match-clause)
;(trace force-tng)
;(trace eval-app)
;(trace eval-ThiNG-inner)