etng-r2/compile-to-scheme.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 278 843b43973b4c
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
(define previous-inspector (current-inspector))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
(current-inspector (make-inspector))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
     4
(define-record-type etng-alternation
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
     5
  (make-etng-alternation clauses)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
     6
  etng-alternation?
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
     7
  (clauses etng-alternation-clauses))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
(current-inspector previous-inspector)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
;---------------------------------------------------------------------------
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    13
(define etng-namespaces '())
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    14
(define implicit-etng-namespace #f)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    15
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    16
(define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#")
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    17
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    18
(define (set-etng-namespace! prefix url)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    19
  (cond
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    20
   ((assq prefix etng-namespaces) =>
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    21
    (lambda (cell) (set-box! (cdr cell) url)))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    22
   (else
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    23
    (set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces)))))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    24
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    25
(set-etng-namespace! '|| builtin-namespace-url)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    26
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    27
(define (mangle-etng-id* url localname)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    28
  (string->symbol (string-append "etng___" url (symbol->string localname))))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    29
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
(define (mangle-etng-id id)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
  (cond
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    32
   ((qname? id)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    33
    (cond
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    34
     ((assq (qname-uri id) etng-namespaces) =>
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    35
      (lambda (entry)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    36
	(mangle-etng-id* (unbox (cdr entry)) (qname-localname id))))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    37
     (else
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    38
      (error 'unknown-qname-prefix id))))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    39
   ((symbol? id)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    40
    (if implicit-etng-namespace
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    41
	(mangle-etng-id* implicit-etng-namespace id)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    42
	(mangle-etng-id* "" id)))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
   (else (error 'invalid-etng-id id))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    45
(define (etng-send-via-named-proxy receiver localname message)
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    46
  (etng-send* receiver
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    47
	      (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    48
	      message))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
    49
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    50
(define (etng-alternation->parser a)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    51
  (lambda (input ks kf)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    52
    (let loop ((clauses (etng-alternation-clauses a)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    53
      (if (null? clauses)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    54
	  (kf)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    55
	  ((car clauses) input ks (lambda () (loop (cdr clauses))))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    56
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    57
(define (make-parser-invocation first-message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    58
  (let ((fragments-rev (make-parameter (list first-message))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    59
    (define (fragment-following f)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    60
      (let search ((candidate #f)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    61
		   (fs (fragments-rev)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    62
	(cond
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    63
	 ((null? fs) (error 'should-not-reach-here 'fragment-following))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    64
	 ((eq? (car fs) f) candidate)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    65
	 (else (search (car fs) (cdr fs))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    66
    (define (remaining-input-following f)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    67
      (let search ((acc '())
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    68
		   (fs (fragments-rev)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    69
	(cond
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    70
	 ((null? fs) (error 'should-not-reach-here 'fragment-following))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    71
	 ((eq? (car fs) f) acc)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    72
	 (else (search (append (car fs) acc) (cdr fs))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    73
    (define (stream-fragment f)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    74
      (let loop ((position f))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    75
	(lambda (op k)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    76
	  (case op
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    77
	    ((next)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    78
	     (if (null? position)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    79
		 (let ((next-fragment (fragment-following f)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    80
		   (if next-fragment
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    81
		       ((stream-fragment next-fragment) 'next k)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    82
		       (let ((so-far (fragments-rev)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    83
			 (lambda (ignored-receiver)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    84
			   (lambda (message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    85
			     (parameterize ((fragments-rev (cons message so-far)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    86
			       ((stream-fragment message) 'next k)))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    87
		 (k (car position) (loop (cdr position)))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    88
	    ((rest)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    89
	     (k (append position (remaining-input-following f))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    90
	    (else
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    91
	     (error 'invalid-op op))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    92
    (stream-fragment first-message)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    93
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    94
(define (etng-lookup via message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    95
  (cond
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    96
   ((etng-alternation? via)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    97
    ((etng-alternation->parser via)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    98
     (make-parser-invocation message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
    99
     (lambda (rhs-thunk-waiting-for-self remaining-input)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   100
       (remaining-input 'rest
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   101
			(lambda (remaining-message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   102
			  (if (null? remaining-message)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   103
			      rhs-thunk-waiting-for-self
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   104
			      (lambda (receiver)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   105
				(etng-send (rhs-thunk-waiting-for-self receiver)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   106
					   remaining-message))))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   107
     (lambda () #f)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   108
   ((procedure? via)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   109
    (via message))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   110
   (else 'invalid-via (list via message))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   111
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   112
(define (etng-directly-invokable? x)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   113
  (or (procedure? x) ;; a parser-invocation, (lambda (message) ...)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   114
      (etng-alternation? x) ;; a parser without invocation: see etng-lookup
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   115
      ))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   116
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   117
(define (etng-send* receiver via message)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   118
  (cond
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   119
   ((etng-directly-invokable? via)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   120
    (let ((thunk (or (etng-lookup via message)
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   121
		     (error 'does-not-understand receiver via message))))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   122
      (thunk receiver)))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   123
   ((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   124
   ((string? via) (etng-send-via-named-proxy receiver 'stringProxy message))
229
a08dfaf5fa1b Delegate to symbolProxy on qname as well as symbol.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 221
diff changeset
   125
   ((qname-or-symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message))
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   126
   ((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   127
   ((not via) (etng-send-via-named-proxy receiver 'falseProxy message))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   128
   ((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   129
   (else (error 'illegal-primitive-object receiver via message))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   130
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   131
(define (etng-send receiver message)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   132
  (etng-send* receiver receiver message))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   133
219
3a2c53019601 Function merging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 217
diff changeset
   134
(define (etng-merge-functions f1 f2)
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   135
  (make-etng-alternation (append (etng-alternation-clauses f1) (etng-alternation-clauses f2))))
219
3a2c53019601 Function merging.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 217
diff changeset
   136
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
(define (compile-to-scheme ast)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   139
  (define (schemeify tng-sexp)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   140
    (if (pair? tng-sexp)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   141
	(case (car tng-sexp)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   142
	  ((paren) (map schemeify (cdr tng-sexp)))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   143
	  (else (error 'brack-and-brace-illegal-in-scheme-assembly)))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   144
	tng-sexp))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   145
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   146
  (define (make-definition id val)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   147
    `(namespace-set-variable-value! ',(mangle-etng-id id) ,val))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   148
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   149
  (define (toplevel ast)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   150
    (case (car ast)
221
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   151
      ((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast)))
eb2506613052 Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 220
diff changeset
   152
      ((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast)))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   153
      ((define-value) (make-definition (cadr ast) (expr (caddr ast))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   154
      ((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast)))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   155
      (else (expr ast))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   156
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   157
  (define (expr ast)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   158
    (case (car ast)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   159
      ((ref) (mangle-etng-id (cadr ast)))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   160
      ((lit) `',(cadr ast))
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   161
      ((object) `(make-etng-alternation (list ,@(map (method (cadr ast)) (cddr ast)))))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   162
      ((function) `(make-etng-alternation (list ,@(map (method #f) (cdr ast)))))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   163
      ((tuple) `(vector ,@(map expr (cdr ast))))
258
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   164
      ((send) `(etng-send ,(expr (cadr ast)) (list ,@(map expr (cddr ast)))))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   165
      ((assemble) `(let ,(map (lambda (binding)
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   166
				`(,(car binding) ,(expr (cadr binding))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   167
			      (cadr ast))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   168
		     ,(schemeify (cadr (assq 'scheme (caddr ast))))))))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   169
258
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   170
  (define (pattern p on-success on-failure)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   171
    (case (car p)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   172
      ((discard) on-success)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   173
      ((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   174
      ((lit) `(if (equal? ',(cadr p) _arg)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   175
		  ,on-success
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   176
		  ,on-failure))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   177
      ((tuple) `(if (and (vector? _arg)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   178
			 (= (vector-length _arg) ,(length (cdr p))))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   179
		    ,(let ((tuple-name (gensym '_argtuple)))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   180
		       `(let ((,tuple-name _arg))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   181
			  ,(let match-elts ((elts (cdr p))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   182
					    (index 0))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   183
			     (if (null? elts)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   184
				 on-success
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   185
				 `(let ((_arg (vector-ref ,tuple-name ,index)))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   186
				    ,(pattern (car elts)
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   187
					      (match-elts (cdr elts) (+ index 1))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   188
					      on-failure))))))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   189
		    ,on-failure))))
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   190
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 229
diff changeset
   191
  (define (method self-id)
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   192
    (lambda (ast)
278
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   193
      (let ((body (caddr ast)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   194
	`(lambda (_stream _kt _kf)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   195
	   ,(let loop ((patterns (cadr ast)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   196
	      `(_stream 'next
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   197
			(lambda (_arg _stream)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   198
			  ,(let* ((remaining-patterns (cdr patterns)))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   199
			     (pattern (car patterns)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   200
				      (if (null? remaining-patterns)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   201
					  `(_kt (lambda (,(if self-id
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   202
							      (mangle-etng-id self-id)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   203
							      '_self))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   204
						  ,(expr body))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   205
						_stream)
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   206
					  (loop remaining-patterns))
843b43973b4c Finish implementing the pattern-matching/parsing technique.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   207
				      `(_kf))))))))))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   208
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   209
  (toplevel ast))