etng-r2/main.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 275 9fa7cb5b7075
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
187
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     1
(require srfi/1) ;; lists
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     2
(require srfi/4) ;; homogeneous-numeric-vectors, u8vector
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     3
(require srfi/8) ;; receive
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     4
(require srfi/9) ;; records
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     5
(require srfi/13) ;; strings
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
     6
(require scheme/pretty)
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
(print-struct #t)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
(define previous-inspector (current-inspector))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
(current-inspector (make-inspector))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
(define-record-type tng-qname
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
  (make-qname uri localname)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
  qname?
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
  (uri qname-uri)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
  (localname qname-localname))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
(current-inspector previous-inspector)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
187
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
    20
(require "../../ometa-scheme/ometa.scm")
176a3f4d1042 Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 183
diff changeset
    21
(ometa-library-path "../../ometa-scheme")
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
(define etng-naked-id-terminators (string->list "`.()[]{}:;,'\""))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
(define (char-etng-id-alpha? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
  (or (char-alphabetic? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
      (eqv? ch #\_)))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
(define (char-etng-id-punct? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
  (not (or (char-alphabetic? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
	   (char-whitespace? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
	   (char-numeric? ch)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
	   (memv ch etng-naked-id-terminators))))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
(define (eol-char? c)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
  (or (eqv? c #\return)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
      (eqv? c #\newline)))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
    39
(define (qname-or-symbol? x)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
    40
  (or (qname? x)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
    41
      (symbol? x)))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
    42
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
(define EMPTY-SYMBOL (string->symbol ""))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
(define QUOTE-QNAME (make-qname EMPTY-SYMBOL 'quote))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
(define UNQUOTE-QNAME (make-qname EMPTY-SYMBOL 'unquote))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
(define SEMI (string->symbol ";"))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
(define COMMA (string->symbol ","))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
(define ARROW '->)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
(define DISCARD '_)
230
70e311e51c29 Add pipe syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 227
diff changeset
    50
(define PIPE (string->symbol "|"))
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
(define (list-interleave x xs)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
  (cond
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
   ((null? xs) '())
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
   ((null? (cdr xs)) xs)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
   (else (cons (car xs) (cons x (list-interleave x (cdr xs)))))))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    57
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
(define (invert-sign x) (- x))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
(define (etng-sexp-special-match? sexps qname)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
  (and (pair? sexps)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
       (let ((tok (car sexps)))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
	 (equal? tok qname))))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
(define (special-segment-head? token)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
  (or (equal? token QUOTE-QNAME)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
      (equal? token UNQUOTE-QNAME)
204
90899a08ca40 Parse '%assemble' construct.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 201
diff changeset
    68
      (memq token '(namespace do let %assemble))))
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
183
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    70
(define (->string x)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    71
  (cond
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    72
   ((string? x) x)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    73
   ((symbol? x) (symbol->string x))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    74
   ((qname? x) (string-append (->string (qname-uri x))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    75
			      ":"
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    76
			      (->string (qname-localname x))))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    77
   (else (let ((s (open-output-string)))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    78
	   (write x s)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    79
	   (get-output-string s)))))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
    80
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
(define read-etng* (load-ometa "etng-reader.g"))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
(define parse-etng* (load-ometa "etng-parser.g"))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
(define (read-etng input ks kf)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
  (read-etng* 'sexp input ks kf))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
(define (read-etng-toplevel input ks kf)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
  (read-etng* 'sexp-toplevel input ks kf))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
200
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    90
(define pass-common (opt (parse-ometa-file "etng-pass-common.g")))
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    91
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
    92
(define (load-pass grammar-filename)
200
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    93
  (let ((g (merge-ometa pass-common (parse-ometa-file grammar-filename))))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
    94
    (lambda (input)
200
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    95
      (simple-ometa-driver g
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    96
			   'pass
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    97
			   (->input-stream (list input))
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    98
			   (lambda (result next err) result)
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
    99
			   (lambda (err)
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
   100
			     (pretty-print `(,grammar-filename ,err))(newline)
466a5b65f1bf Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 199
diff changeset
   101
			     #f)))))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   102
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   103
(define null-pass (load-pass "etng-null-pass.g"))
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   104
201
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   105
(define convert-constant-methods-pass (load-pass "etng-convert-constant-methods-pass.g"))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   106
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   107
(define (convert-constant-methods ast-prefix methods)
201
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   108
  (let loop ((methods methods)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   109
	     (reversed-temporaries '())
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   110
	     (reversed-initializers '())
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   111
	     (transformed-methods '()))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   112
    (if (null? methods)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   113
	(let ((new-methods (reverse transformed-methods))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   114
	      (temporaries (reverse reversed-temporaries))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   115
	      (initializers (reverse reversed-initializers)))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   116
	  (cond
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   117
	   ((null? temporaries)
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   118
	    `(,@ast-prefix ,@new-methods))
201
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   119
	   ((null? (cdr temporaries))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   120
	    `(send (function (method ((bind ,(car temporaries)))
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   121
				     (,@ast-prefix ,@new-methods)))
201
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   122
		   ,(car initializers)))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   123
	   (else
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   124
	    `(send (function (method ((tuple ,@(map (lambda (temp) `(bind ,temp)) temporaries)))
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   125
				     (,@ast-prefix ,@new-methods)))
201
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   126
		   (tuple ,@initializers)))))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   127
	(let ((method (car methods)))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   128
	  (if (eq? (car method) 'constant-method)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   129
	      (let ((temp (gensym)))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   130
		(loop (cdr methods)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   131
		      (cons temp reversed-temporaries)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   132
		      (cons (caddr method) reversed-initializers)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   133
		      (cons `(method ,(cadr method) (ref ,temp)) transformed-methods)))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   134
	      (loop (cdr methods)
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   135
		    reversed-temporaries
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   136
		    reversed-initializers
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   137
		    (cons method transformed-methods)))))))
9b22b7a23e39 Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 200
diff changeset
   138
205
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   139
(define (alpha-convert-expr exp conversions)
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   140
  (define (convert-method method)
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   141
    `(,(car method)
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   142
      ,(map (lambda (p) (alpha-convert-pattern p conversions)) (cadr method))
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   143
      ,(alpha-convert-expr (caddr method) conversions)))
205
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   144
  (case (car exp)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   145
    ((ref) `(ref ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp)))))
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   146
    ((lit) exp)
234
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   147
    ((object) `(,(car exp) ,(cadr exp) ,@(map convert-method (cddr exp))))
10e62e160cb0 Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 230
diff changeset
   148
    ((function) `(,(car exp) ,@(map convert-method (cdr exp))))
205
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   149
    ((tuple) `(tuple ,@(map (lambda (x) (alpha-convert-expr x conversions)) (cdr exp))))
258
4d06e035b80e Begin adapting evaluator to codegen
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 234
diff changeset
   150
    ((send) `(send ,@(map (lambda (x) (alpha-convert-expr x conversions)) (cdr exp))))))
205
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   151
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   152
(define (alpha-convert-pattern pat conversions)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   153
  (case (car exp)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   154
    ((discard) exp)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   155
    ((bind) `(bind ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp)))))
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   156
    ((lit) exp)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   157
    ((tuple) `(tuple ,@(map (lambda (p) (alpha-convert-pattern p conversions)) (cdr exp))))))
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   158
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   159
(define (names-in-pattern p)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   160
  (case (car p)
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   161
    ((discard) '())
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   162
    ((bind) (list (cadr p)))
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   163
    ((lit) '())
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   164
    ((tuple) (append-map names-in-pattern (cdr p)))))
0ab03377df02 Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 204
diff changeset
   165
183
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   166
(define (etng-sexp->string-tree e)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   167
  (cond
210
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   168
   ((pair? e) (cond
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   169
	       ((and (eq? (car e) 'paren)
218
e1adb1b53cc0 It's not an error (!) to have an empty (paren) etng-sexp.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 217
diff changeset
   170
		     (pair? (cdr e))
210
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   171
		     (equal? (cadr e) QUOTE-QNAME))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   172
		`("." ,(etng-sexp->string-tree (caddr e))))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   173
	       (else
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   174
		((case (car e)
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   175
		   ((paren) (lambda (es) `("(" ,es ")")))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   176
		   ((brack) (lambda (es) `("[" ,es "]")))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   177
		   ((brace) (lambda (es) `("{" ,es "}")))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   178
		   (else (error 'illegal-sexp e)))
3776775f3738 When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 208
diff changeset
   179
		 (list-interleave " " (map etng-sexp->string-tree (cdr e)))))))
183
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   180
   ((string? e) e)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   181
   (else (->string e))))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   182
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   183
(define (cons-tree-for-each f l)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   184
  (let walk ((l l))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   185
    (if (pair? l)
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   186
	(begin (walk (car l)) (walk (cdr l)))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   187
	(f l))))
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   188
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   189
(define (pp clue x . maybe-transformer)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   190
  (pretty-print (list clue 
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   191
		      (if (null? maybe-transformer)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   192
			  x
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   193
			  ((car maybe-transformer) x))))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   194
  (newline)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   195
  x)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   196
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   197
(define (!pp clue x . maybe-transformer)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   198
  x)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   199
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   200
(define (dump-string-tree t)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   201
  (cons-tree-for-each (lambda (x) (or (null? x) (display x))) t)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   202
  (newline))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   203
211
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   204
(define (mark-position pos-path t)
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   205
  (if (null? pos-path)
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   206
      t
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   207
      (call-with-values (lambda () (split-at t (car pos-path)))
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   208
	(lambda (left right)
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   209
	  (if (null? (cdr pos-path))
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   210
	      (append left (list "<@@@@@>") right)
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   211
	      (append left (list (mark-position (cdr pos-path) (car right))) (cdr right)))))))
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   212
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   213
(define (display-parse-error clue err . maybe-ast)
207
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   214
  (display clue)
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   215
  (newline)
211
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   216
  (when (not (null? maybe-ast))
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   217
    (dump-string-tree (etng-sexp->string-tree (car (mark-position (car err)
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   218
								  (list (car maybe-ast)))))))
207
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   219
  (display (format-ometa-error err))
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   220
  (newline))
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   221
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   222
(define (parse-print-and-eval sexp evaluator)
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   223
  ;; (pp 'raw-sexp sexp) (newline)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   224
  (dump-string-tree (etng-sexp->string-tree sexp))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   225
  (parse-etng* 'toplevel (list sexp)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   226
	       (lambda (ast dummy-next err)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   227
		 (if (null? (input-stream->list dummy-next))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   228
		     (evaluator ast)
211
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   229
		     (display-parse-error "Partial parse." err sexp)))
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   230
	       (lambda (err)
211
bd01f1a8bbae Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 210
diff changeset
   231
		 (display-parse-error "Unsuccessful parse." err sexp))))
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   232
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   233
(load "compile-to-scheme.scm")
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   234
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   235
(define (rude-evaluator input)
275
9fa7cb5b7075 Silence debug output again
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   236
  (let* ((ast (!pp 'ast input))
227
da3853e42ca1 Make the repl a bit quieter.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 218
diff changeset
   237
	 (ast (!pp 'convert-constant-methods-pass (convert-constant-methods-pass ast)))
275
9fa7cb5b7075 Silence debug output again
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 258
diff changeset
   238
	 (scheme-ast (!pp 'compile-to-scheme (compile-to-scheme ast)))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   239
	 (thunk (!pp 'compile-scheme (eval `(lambda () ,scheme-ast))))
208
0fb5d58b308c Cosmetic: move a close-paren to make cleaner future diffs on pass insertion.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 207
diff changeset
   240
	 )
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   241
    (write (thunk))
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   242
    (newline)))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   243
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   244
(define (etng-parse-file* filename evaluator)
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   245
  (call-with-input-file filename
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   246
    (lambda (handle)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   247
      (let loop ((input (->input-stream handle)))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   248
	(read-etng-toplevel
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   249
	 input
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   250
	 (lambda (sexp0 next err)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   251
	   (if (eq? sexp0 'eof)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   252
	       'eof-reached
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   253
	       (let ((sexp (cons 'paren sexp0)))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   254
		 (parse-print-and-eval sexp evaluator)
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   255
		 (when (and next (not (eq? next input)))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   256
		   (loop next)))))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   257
	 (lambda (error-description)
207
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   258
	   (display-parse-error "Reader failure." error-description)))))))
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   259
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   260
(define (etng-parse-file filename)
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   261
  (etng-parse-file* filename rude-evaluator))
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   262
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   263
(define (etng-repl* evaluator)
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   264
  (let loop ((input (current-input-stream)))
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   265
    (display ">>ETNG>> ")
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   266
    (flush-output)
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   267
    (read-etng-toplevel
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   268
     input
183
d6199b03d787 Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 182
diff changeset
   269
     (lambda (sexp0 next err)
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   270
       (if (eq? sexp0 'eof)
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   271
	   'eof-reached
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   272
	   (let ((sexp (cons 'paren sexp0)))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   273
	     (parse-print-and-eval sexp evaluator)
198
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   274
	     (when (and next (not (eq? next input)))
072745b48add Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 187
diff changeset
   275
	       (loop next)))))
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   276
     (lambda (error-description)
207
b913a690a851 Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 205
diff changeset
   277
       (display-parse-error "Reader failure." error-description)
181
f82ec080be39 etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   278
       (loop (current-input-stream))))))
199
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   279
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   280
(define (etng-repl)
043539ed8a21 Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 198
diff changeset
   281
  (etng-repl* rude-evaluator))
217
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   282
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   283
(etng-parse-file "boot.tng")
99d5b8250c37 Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 211
diff changeset
   284
(etng-repl)