ometa.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Mon, 04 Jul 2011 10:59:25 -0400
changeset 37 c28094727b3d
parent 35 5a234972f72a
permissions -rw-r--r--
Cope with no reported error when formatting error messages.
12
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
     1
#lang scheme
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
;; OMeta Library
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
;;
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
;; Copyright (c) 2008 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
;; Copyright (c) 2008 LShift Ltd. <query@lshift.net>
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
;; 
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
;; Permission is hereby granted, free of charge, to any person
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
;; obtaining a copy of this software and associated documentation
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
;; files (the "Software"), to deal in the Software without
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
;; restriction, including without limitation the rights to use, copy,
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
;; modify, merge, publish, distribute, sublicense, and/or sell copies
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
;; of the Software, and to permit persons to whom the Software is
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
;; furnished to do so, subject to the following conditions:
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
;; 
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
;; The above copyright notice and this permission notice shall be
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
;; included in all copies or substantial portions of the Software.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
;; 
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
;; SOFTWARE.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
;; Requires: SRFI-1, SRFI-9, SRFI-13, SRFI-69. See the documentation for more
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
;; details.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
;; FIXME: move to wrapper
12
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    31
(require errortrace/errortrace-lib)
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    32
(require (except-in srfi/1 reverse! member map for-each assoc append!)
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    33
         srfi/9
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    34
         (except-in srfi/13 string-hash)
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    35
         srfi/69
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    36
         )
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    37
1d25ebbef574 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
    38
(provide (all-defined-out))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
;; A parse position is a path. The tip of the path changes as we
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    41
;; consume tokens. Recursive parses push a new tip onto the path.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
;; For files, a path tip is a (filename line column) triple.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
;; Tips must be lists, strings, or numbers.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
;; Lists have their most-significant element first.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
26
7b14cfdd890a Make *ometa-debug* a parameter instead of a normal variable.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 25
diff changeset
    46
(define *ometa-debug* (make-parameter #f))
25
4eb82d12ddd7 Allow for external setting of *ometa-debug*.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 24
diff changeset
    47
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
;; false < numbers < strings < empty-list < list < true
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
(define (parse-position-type-index x)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    50
  (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
   ((not x) 0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
   ((number? x) 1)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
   ((string? x) 2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
   ((null? x) 3)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
   ((pair? x) 4)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
   ((eq? x #t) 5)
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
    57
   (else (error 'parse-position-type-index "Invalid parse-position ~v" x))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
(define parse-position-type-predicates
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
  (vector (lambda (a b) #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
	  >
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
	  string>?
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
	  (lambda (a b) #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
	  (lambda (a b)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
	    (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
	     ((parse-position>? (car a) (car b)) #t)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
	     ((parse-position>? (car b) (car a)) #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
	     (else (parse-position>? (cdr a) (cdr b)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
	  (lambda (a b) #f)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    71
(define (parse-position>? a b)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    72
  (let ((ta (parse-position-type-index a))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    73
	(tb (parse-position-type-index b)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    74
    (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    75
     ((> ta tb) #t)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    76
     ((< ta tb) #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    77
     (else ((vector-ref parse-position-type-predicates ta) a b)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    78
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    79
(define (top-file-parse-position filename)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    80
  (list filename 1 0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
(define (update-file-parse-position pos ch)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
  (case ch
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
    ((#\return) (list (car pos) (cadr pos) 0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
    ((#\newline) (list (car pos) (+ (cadr pos) 1) 0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
    ((#\tab) (list (car pos) (cadr pos) (* (quotient (+ (caddr pos) 8) 8) 8)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
    (else (list (car pos) (cadr pos) (+ (caddr pos) 1)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
(define (pretty-printN . xs)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
  (pretty-print xs)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    91
  (last xs))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    92
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    93
;; A parse error is a pair of position-path and lset of error reports.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    94
;; (<position> . (<error-report> ...))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    95
(define (merge-parse-errors e1 e2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    96
  ;;(pretty-printN `(merge ,e1 ,e2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    97
  (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    98
   ((not e1) e2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    99
   ((not e2) e1)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   100
   (else (let ((p1 (car e1))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   101
	       (p2 (car e2)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   102
	   (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   103
	    ((or (parse-position>? p1 p2) (null? (cdr e2))) e1)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   104
	    ((or (parse-position>? p2 p1) (null? (cdr e1))) e2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   105
	    (else (cons p1 (lset-union equal? (cdr e1) (cdr e2)))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   106
  ;;)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   107
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
(define (merge-success prev-err ks)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   109
  (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   110
    (ks sv new-env next (merge-parse-errors err prev-err))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   111
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   112
(define (merge-failure prev-err kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   113
  (lambda (err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   114
    (kf (merge-parse-errors err prev-err))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   115
29
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   116
;; Note that the argument pos is a parse position tip, not a position
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   117
;; path. It's wrapped in a list, making it into a position path,
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   118
;; before being placed in the error structure. See also
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   119
;; contextualize-parse-error.
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   120
(define (make-parse-error pos error-report)
29
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   121
  (cons (list pos) (list error-report)))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   122
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   123
;; Note that the argument pos is a parse position tip, not a position
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   124
;; path. It is prepended to the position path in err, thereby placing
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   125
;; the err in the context of pos.
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   126
(define (contextualize-parse-error pos err)
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   127
  (and err (cons (cons pos (car err)) (cdr err))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   128
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   129
;; Input streams need to supply
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   130
;;  - head item
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   131
;;  - parse position tip (not a position path!)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   132
;;  - tail stream
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   133
;;
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   134
;; Only the parse position tip gets passed on EOF.
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   135
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   136
(define (input-stream-cons pos item tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
  (lambda (ks kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
    (ks pos item tail)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   139
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   140
(define (input-stream-position stream)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   141
  (stream (lambda (pos item tail) pos)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   142
	  (lambda (pos) pos)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   143
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   144
(define (input-stream-append s1 s2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   145
  (lambda (ks kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   146
    (s1 (lambda (pos item tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   147
	  (ks pos item (input-stream-append tail s2)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   148
	(lambda (pos)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   149
	  (s2 ks kf)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   150
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   151
(define input-stream-constructors '())
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   152
28
0a56ed00bf44 If an item cannot be converted to an input-stream in a recursive parse,
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 27
diff changeset
   153
(define (->input-stream-or-false x)
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   154
  (let search ((ctors input-stream-constructors))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   155
    (cond
28
0a56ed00bf44 If an item cannot be converted to an input-stream in a recursive parse,
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 27
diff changeset
   156
     ((null? ctors) #f)
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   157
     (((caar ctors) x) ((cdar ctors) x))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   158
     (else (search (cdr ctors))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   159
28
0a56ed00bf44 If an item cannot be converted to an input-stream in a recursive parse,
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 27
diff changeset
   160
(define (->input-stream x)
0a56ed00bf44 If an item cannot be converted to an input-stream in a recursive parse,
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 27
diff changeset
   161
  (or (->input-stream-or-false x)
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   162
      (error '->input-stream "Could not construct input stream from ~v" x)))
28
0a56ed00bf44 If an item cannot be converted to an input-stream in a recursive parse,
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 27
diff changeset
   163
8
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   164
(define (input-stream-split-at-most input i k)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   165
  (let loop ((acc '())
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   166
	     (i i)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   167
	     (input input))
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   168
    (if (zero? i)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   169
	(k (reverse acc) input)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   170
	(input (lambda (pos item tail) (loop (cons item acc) (- i 1) tail))
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   171
	       (lambda (pos) (k (reverse acc) input))))))
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   172
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   173
(define (input-stream->list input)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   174
  (input (lambda (pos item tail) (cons item (input-stream->list tail)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   175
	 (lambda (pos) '())))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   176
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   177
(define (register-input-stream-constructor! predicate ctor)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   178
  (set! input-stream-constructors
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   179
	(cons (cons predicate ctor)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   180
	      input-stream-constructors)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   181
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   182
(register-input-stream-constructor!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   183
 procedure? ;; covering input streams themselves
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   184
 (lambda (s)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   185
   s))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   186
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   187
(register-input-stream-constructor!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   188
 list?
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   189
 (lambda (l)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   190
   (let loop ((position 0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   191
	      (l l))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   192
     (if (null? l)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   193
	 (lambda (ks kf) (kf position))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   194
	 (lambda (ks kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   195
	   (ks position (car l) (loop (+ position 1) (cdr l))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   196
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   197
(register-input-stream-constructor!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   198
 string?
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   199
 (lambda (s)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   200
   (let ((len (string-length s)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   201
     (let loop ((index 0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   202
		(position (top-file-parse-position "<string>")))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   203
       (if (= index len)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   204
	   (lambda (ks kf) (kf position))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   205
	   (lambda (ks kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   206
	     (let ((ch (string-ref s index)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   207
	       (ks position
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   208
		   ch
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   209
		   (loop (+ index 1)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   210
			 (update-file-parse-position position ch))))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   211
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   212
(register-input-stream-constructor!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   213
 vector?
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   214
 (lambda (v)
16
56d3acb0f216 Correct vector input stream constructor.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 13
diff changeset
   215
   (let ((len (vector-length v)))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   216
     (let loop ((index 0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   217
       (if (= index len)
13
a01d1ef1e25f Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   218
           (lambda (ks kf) (kf index))
16
56d3acb0f216 Correct vector input stream constructor.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 13
diff changeset
   219
           (lambda (ks kf) (ks index (vector-ref v index) (loop (+ index 1)))))))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   220
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   221
(register-input-stream-constructor!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   222
 input-port?
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   223
 (lambda (p)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   224
   (make-port-input-stream "<unknown>" p)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   225
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   226
(define (make-port-input-stream filename p)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   227
  (let loop ((position (top-file-parse-position filename)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   228
    (let ((ch (read-char p)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   229
      (if (eof-object? ch)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   230
	  (lambda (ks kf) (kf position))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   231
	  (let ((next (delay (loop (update-file-parse-position position ch)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   232
	    (lambda (ks kf) (ks position ch (force next))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   233
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   234
(define (current-input-stream)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   235
  (make-port-input-stream "<stdin>" (current-input-port)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   236
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   237
;; The result of parsing is either (semantic-value * new-env * next * error) or (error)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   238
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   239
;; (apply production-name arg ...) ; both name and arg may be variables; args implicit - pushed on the input stream!
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   240
;; (or parser ...)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   241
;; (exactly datum) ; nil true false <number> 'string' #symbol $c "sequence of chars"
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   242
;; (sequence)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   243
;; ; () for grouping
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   244
;; (nest parser) ; nested parse! (sequence)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   245
;; (not parser)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   246
;; (follow parser)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   247
;; (many parser)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   248
;; (many1 parser)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   249
;; (bind name parser)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   250
;; (seq parser ...)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   251
;; (anything)
32
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   252
;; (position)
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   253
;; (action meta-exp); -> exp, ?exp
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   254
33
bec0f2436e38 Update mzscheme namespace usage for eval to use namespace anchors
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 32
diff changeset
   255
(define-namespace-anchor ometa-namespace-anchor)
bec0f2436e38 Update mzscheme namespace usage for eval to use namespace anchors
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 32
diff changeset
   256
(define ometa-namespace-getter
bec0f2436e38 Update mzscheme namespace usage for eval to use namespace anchors
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 32
diff changeset
   257
  (make-parameter
bec0f2436e38 Update mzscheme namespace usage for eval to use namespace anchors
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 32
diff changeset
   258
   (lambda ()
bec0f2436e38 Update mzscheme namespace usage for eval to use namespace anchors
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 32
diff changeset
   259
     (namespace-anchor->namespace ometa-namespace-anchor))))
23
43e844567223 Make namespace used by eval configurable.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 20
diff changeset
   260
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   261
(define (interpret-ometa start rules input ks kf)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   262
  (define (eval-host exp env k)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   263
    (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   264
     ((symbol? exp)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   265
      (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   266
       ((assq exp env) => (lambda (entry) (k (cadr entry) (cddr entry))))
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   267
       (else (error 'interpret-ometa "Unbound variable ~v" exp))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   268
     ((pair? exp)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   269
      (case (car exp)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   270
	((quote) (k #f (cadr exp)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   271
	(else
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   272
	 (error 'interpret-ometa "Applications not supported in eval-host: ~v" exp))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   273
     (else (k #f exp))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   274
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   275
  (define (push-actuals args env tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   276
    (if (null? args)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   277
	tail
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   278
	(eval-host (car args) env
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   279
		   (lambda (pos value)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   280
		     (input-stream-cons pos value (push-actuals (cdr args) env tail))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   281
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   282
  (define (collect-many exp env acc input err0 ks)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   283
    (let collect ((acc acc)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   284
		  (input input)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   285
		  (prev-err err0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   286
      ;;(pretty-print `(collect-many ,(input-stream-position input) ,exp ,acc ,prev-err))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   287
      (e exp env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   288
	 (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   289
	   (collect (cons sv acc) next (merge-parse-errors err prev-err)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   290
	 (lambda (err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   291
	   ;;(pretty-print `(leaving ,exp ,acc ,prev-err and ,err))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   292
	   (ks (reverse acc) env input (merge-parse-errors err prev-err))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   293
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   294
  (define (nonshared-env env)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   295
    (if (eq? env rules)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   296
	'()
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   297
	(cons (car env) (nonshared-env (cdr env)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   298
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   299
  (define (nonshared-env-values env)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   300
    (if (eq? env rules)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   301
	'()
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   302
	(cons (cddar env) (nonshared-env-values (cdr env)))))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   303
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   304
  (define (shadowed-identifier s)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   305
    (string->symbol (string-append "_" (symbol->string s))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   306
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   307
  (define (nonshared-env-names env)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   308
    (let loop ((env env)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   309
	       (acc '()))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   310
      (cond
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   311
       ((eq? env rules) (reverse acc))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   312
       ((memq (caar env) acc) (loop (cdr env) (cons (shadowed-identifier (caar env)) acc)))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   313
       (else (loop (cdr env) (cons (caar env) acc))))))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   314
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   315
  (define (compile-meta-exp exp names)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   316
    (let ((success-sym (gensym)))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   317
      (let ((source-form `(lambda (,success-sym error ,@names)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   318
			    (,success-sym ,exp))))
7
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   319
	;;(pretty-print `((names ,names) (source-form ,source-form)))(newline)
23
43e844567223 Make namespace used by eval configurable.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 20
diff changeset
   320
	(eval source-form ((ometa-namespace-getter))))))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   321
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   322
  (define memo-tab (make-hash-table equal?))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   323
  (define action-tab (make-hash-table equal?))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   324
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   325
  (define (e exp env input ks kf)
35
5a234972f72a Split debug parameter into non-false and true levels.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 34
diff changeset
   326
    (when (eq? (*ometa-debug*) #t)
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   327
	(pretty-print `(
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   328
			(exp ,exp)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   329
			(env ,(nonshared-env env))
8
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   330
			(input ,(let ((l (input-stream-split-at-most input 32 (lambda (h t) h))))
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   331
				  (if (every char? l)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   332
				      (list->string l)
0e3da81b1a3b Improve debug output
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 7
diff changeset
   333
				      l)))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   334
			(pos ,(input-stream-position input))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   335
			)))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   336
    (case (car exp)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   337
      ((apply)
35
5a234972f72a Split debug parameter into non-false and true levels.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 34
diff changeset
   338
       (when (*ometa-debug*)
5a234972f72a Split debug parameter into non-false and true levels.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 34
diff changeset
   339
	 (pretty-print `(apply (exp ,exp)
5a234972f72a Split debug parameter into non-false and true levels.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 34
diff changeset
   340
			       (pos ,(input-stream-position input)))))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   341
       (let search-for-production ((production-exp (cadr exp)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   342
	 (eval-host production-exp env
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   343
	   (lambda (dummy-pos production)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   344
	     (if (symbol? production)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   345
		 (search-for-production production)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   346
		 (let ((args (cddr exp)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   347
		   (if (null? args)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   348
		       (let ((memo-probe (cons input production)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   349
			 (if (hash-table-exists? memo-tab memo-probe)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   350
			     ((hash-table-ref memo-tab memo-probe)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   351
			      (lambda (sv new-env next err) (ks sv env next err))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   352
			      kf)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   353
			     (e production rules input
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   354
				(lambda (sv new-env next err)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   355
				  (hash-table-set! memo-tab memo-probe
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   356
						   (lambda (ks kf) (ks sv new-env next err)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   357
				  (ks sv env next err))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   358
				(lambda (err)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   359
				  (hash-table-set! memo-tab memo-probe
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   360
						   (lambda (ks kf) (kf err)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   361
				  (kf err)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   362
		       (let ((extended-input (push-actuals args env input)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   363
			 (e production rules extended-input
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   364
			    (lambda (sv new-env next err)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   365
			      (ks sv env next err))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   366
			    kf)))))))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   367
      ((or)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   368
       (if (null? (cdr exp))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   369
	   (kf #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   370
	   (let loop ((options (cdr exp))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   371
		      (prev-err #f))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   372
	     (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   373
	      ((null? (cdr options))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   374
	       (e (car options) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   375
		  (merge-success prev-err ks)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   376
		  (merge-failure prev-err kf)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   377
	      (else (e (car options) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   378
		       (merge-success prev-err ks)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   379
		       (lambda (err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   380
			 (loop (cdr options) (merge-parse-errors err prev-err)))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   381
      ((exactly)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   382
       (let ((expected-value (cadr exp)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   383
	 (input (lambda (pos item tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   384
		  (if (equal? item expected-value)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   385
		      (ks item env tail #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   386
		      (kf (make-parse-error pos `(expected ,expected-value)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   387
		(lambda (pos)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   388
		  (kf (make-parse-error pos `(expected ,expected-value)))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   389
      ((sequence)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   390
       (eval-host (cadr exp) env
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   391
	 (lambda (dummy-pos item0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   392
	   (let ((pos0 (input-stream-position input)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   393
	     (let loop ((xs (if (string? item0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   394
				(string->list item0)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   395
				item0))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   396
			(input input))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   397
	       ;;(pretty-print `(in-sequence ,xs ,(list->string (input-stream->list input))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   398
	       (if (null? xs)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   399
		   (ks item0 env input #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   400
		   (input (lambda (pos item tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   401
			    (if (equal? item (car xs))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   402
				(loop (cdr xs) tail)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   403
				(kf (make-parse-error pos0 `(expected ,item0)))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   404
			  (lambda (pos)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   405
			    (kf (make-parse-error pos0 `(expected ,item0)))))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   406
      ((nest)
29
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   407
       (let ((context-position (input-stream-position input)))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   408
	 (input (lambda (pos item tail)
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   409
		  (let ((stream (->input-stream-or-false item)))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   410
		    (if stream
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   411
			(e (cadr exp) env stream
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   412
			   (lambda (sv new-env next err)
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   413
			     (ks sv new-env tail (contextualize-parse-error context-position err)))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   414
			   (lambda (err)
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   415
			     (kf (contextualize-parse-error context-position err))))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   416
			(kf #f))))
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   417
		(lambda (pos)
7b6adad58777 Track position paths, not just position tips. This gives much better error locs.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 28
diff changeset
   418
		  (kf #f)))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   419
      ((not)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   420
       (e (cadr exp) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   421
	  (lambda (sv new-env next err)
30
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   422
	    (kf (make-parse-error (input-stream-position input) `(unexpected ,(cadr exp)))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   423
	  (lambda (err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   424
	    (ks #t env input #f))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   425
      ((follow)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   426
       (e (cadr exp) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   427
	  (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   428
	    (ks sv new-env input err))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   429
	  kf))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   430
      ((many)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   431
       (collect-many (cadr exp) env '() input #f ks))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   432
      ((many1)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   433
       (e (cadr exp) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   434
	  (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   435
	    (collect-many (cadr exp) env (list sv) next err ks))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   436
	  kf))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   437
      ((bind)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   438
       (e (caddr exp) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   439
	  (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   440
	    (ks sv
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   441
		(cons (cons (cadr exp) (cons (input-stream-position input) sv)) new-env)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   442
		next
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   443
		err))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   444
	  kf))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   445
      ((seq)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   446
       (if (null? (cdr exp))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   447
	   (ks #f env input #f)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   448
	   (let loop ((exps (cdr exp))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   449
		      (env env)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   450
		      (input input)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   451
		      (prev-err #f))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   452
	     ;;(pretty-print `(in-seq (exps ,exps) (env ,(nonshared-env env))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   453
	     (if (null? (cdr exps))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   454
		 (e (car exps) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   455
		    (merge-success prev-err ks)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   456
		    (merge-failure prev-err kf))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   457
		 (e (car exps) env input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   458
		    (lambda (sv new-env next err)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   459
		      (loop (cdr exps) new-env next (merge-parse-errors err prev-err)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   460
		    (merge-failure prev-err kf))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   461
      ((anything)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   462
       (input (lambda (pos item tail) (ks item env tail #f))
30
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   463
	      (lambda (pos) (kf #f))))
32
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   464
      ((position)
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   465
       (ks (input-stream-position input) env input #f))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   466
      ((action)
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   467
       (let* ((names (nonshared-env-names env))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   468
	      (probe (cons (cadr exp) names))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   469
	      (fn (if (hash-table-exists? action-tab probe)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   470
		      (hash-table-ref action-tab probe)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   471
		      (let ((v (compile-meta-exp (cadr exp) names)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   472
			(hash-table-set! action-tab probe v)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   473
			v)))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   474
	      (escape '*)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   475
	      (escaped (call-with-current-continuation
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   476
			(lambda (set-escaped!)
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   477
			  (set! escape (lambda error-report
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   478
					 (set-escaped! error-report)))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   479
			  #f))))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   480
	 (if escaped
30
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   481
	     (kf (if (null? escaped)
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   482
		     #f
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   483
		     (make-parse-error (input-stream-position input) escaped)))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   484
	     (apply fn
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   485
		    (lambda (sv) (ks sv env input #f))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   486
		    escape
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   487
		    (nonshared-env-values env)))))
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   488
      (else (error 'interpret-ometa "Bad OMeta AST: ~v" exp))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   489
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   490
  (e `(apply ,start) rules input
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   491
     ks
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   492
     kf))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   493
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   494
(define (grammar->env g)
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   495
  (map (lambda (raw-production)
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   496
	 (cons (car raw-production)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   497
	       (cons #f ;; parse-position
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   498
		     (cadr raw-production))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   499
       g))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   500
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   501
(define meta-ometa
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   502
  '(
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   503
    (productions (many1 (apply production)))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   504
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   505
    (production (seq (bind n (follow (apply name)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   506
		     (bind x (apply production-part n))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   507
		     (bind xs (many (seq (apply token ";")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   508
					 (apply production-part n))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   509
		     (apply token ";")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   510
		     (apply spaces)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   511
		     (action `(,n (or ,x ,@xs)))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   512
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   513
    (production-part (seq (bind required-name (anything))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   514
			  ;;
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   515
			  (bind n (apply name))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   516
			  (action (or (eq? n required-name)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   517
				      (error 'clause-name-mismatch)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   518
			  (bind body (apply expr-seq))
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   519
			  (or (seq (apply token "=")
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   520
				   (bind rhs (apply expr))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   521
				   (action `(seq ,body ,rhs)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   522
			      (action body))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   523
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   524
    (expr-seq (seq (bind xs (many (apply expr3)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   525
		   (action `(seq ,@xs))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   526
32
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   527
    (expr3 (or (seq (bind r (or (seq (bind r (apply expr2))
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   528
				     (or (seq (apply token "*") (action `(many ,r)))
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   529
					 (seq (apply token "+") (action `(many1 ,r)))
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   530
					 (action r)))
5deee5dae03d Support @ for current parse position.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 30
diff changeset
   531
				(seq (apply token "@") (action `(position)))))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   532
		    (or (seq (exactly #\:) (bind n (apply name))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   533
			     (action `(bind ,n ,r)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   534
			(action r)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   535
	       (seq (apply token ":") (bind n (apply name))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   536
		    (action `(bind ,n (anything))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   537
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   538
    (expr2 (or (seq (apply token "~") (bind x (apply expr2))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   539
		    (action `(not ,x)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   540
	       (seq (apply token "&") (bind x (apply expr1))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   541
		    (action `(follow ,x)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   542
	       (apply expr1)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   543
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   544
    (expr1 (or (seq (apply token "<{")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   545
		    (bind s (apply host-language-expression))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   546
		    (apply token "}>")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   547
		    (action `(sequence ,s)))
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   548
	       (seq (bind prod-exp (apply name))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   549
		    (bind arg-exps (apply apply-arguments))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   550
		    (action `(apply ,prod-exp ,@arg-exps)))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   551
	       (seq (apply token "->") (bind r (apply host-language-expression))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   552
		    (action `(action ,r)))
6
5a940cd130d8 Support ?predicates.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 5
diff changeset
   553
	       (seq (apply token "?") (bind r (apply host-language-expression))
30
af04a16148de Improve relevance of error reporting by avoiding supplying error reports for
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 29
diff changeset
   554
		    (action `(action (or ,r (error)))))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   555
	       (seq (bind x (apply literal))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   556
		    (action `(exactly ,x)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   557
	       (seq (apply token "_") (action `(anything)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   558
	       (seq (apply token "(") (bind x (apply expr)) (apply token ")")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   559
		    (action x))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   560
	       (seq (apply token "{") (bind xs (apply expr-seq)) (apply token "}")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   561
		    (action `(nest ,xs)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   562
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   563
    (apply-arguments (or (seq (exactly #\( ) ;; no space permitted before open-paren!
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   564
			      (or (seq (apply token ")")
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   565
				       (action '()))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   566
				  (seq (bind a1 (apply scheme-term))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   567
				       (bind aa (many (seq (apply token ",")
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   568
							   (apply scheme-term))))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   569
				       (apply token ")")
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   570
				       (action (cons a1 aa)))))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   571
			 (action '())))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   572
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   573
    (literal (or (apply okeyword "nil" ())
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   574
		 (apply okeyword "true" #t)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   575
		 (apply okeyword "false" #f)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   576
		 (apply onumber)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   577
		 (apply ostring #\')
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   578
		 (seq (apply token "$") (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   579
		 (seq (apply token "#") (or (apply name)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   580
					    (seq (bind s (apply ostring #\'))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   581
						 (action (string->symbol s)))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   582
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   583
    (onumber (seq (apply spaces) (bind ip (many1 (apply digit)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   584
		  (or (seq (exactly #\.) (bind fp (many1 (apply digit)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   585
			   (action (string->number (string-append (list->string ip)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   586
								  "."
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   587
								  (list->string fp)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   588
		      (action (string->number (list->string ip))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   589
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   590
    (ostring (seq (bind quo (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   591
		  ;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   592
		  (apply spaces)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   593
		  (bind s1 (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   594
		  (action (or (eqv? s1 quo) (error 'expected 'string-open-quote)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   595
		  (bind cs (many (or (seq (exactly #\\)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   596
					  (or (exactly #\\)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   597
					      (seq (bind c (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   598
						   (action (if (eqv? c quo)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   599
							       c
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   600
							       (error 'expected
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   601
								      'escaped-quote))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   602
				     (seq (bind c (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   603
					  (action (if (eqv? c quo)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   604
						      (error 'expected 'string-char)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   605
						      c))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   606
		  (bind s2 (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   607
		  (action (if (eqv? s2 quo)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   608
			      (list->string cs)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   609
			      (error 'expected 'string-close-quote)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   610
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   611
    (ochar (seq (bind c (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   612
		(action (if (char? c)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   613
			    c
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   614
			    (error 'expected 'char?)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   615
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   616
    (expr (seq (bind x (apply expr-seq))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   617
	       (bind xs (many (seq (apply token "|") (apply expr-seq))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   618
	       (action `(or ,x ,@xs))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   619
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   620
    (okeyword (seq (bind xs (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   621
		   (bind val (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   622
		   ;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   623
		   (apply spaces) (sequence xs)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   624
		   (not (apply name-subsequent '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\')))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   625
		   (action val)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   626
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   627
    (token (seq (bind xs (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   628
		;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   629
		(apply spaces) (sequence xs)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   630
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   631
    (name (apply generic-name
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   632
		 '()
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   633
		 '(#\- #\_)))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   634
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   635
    (generic-name (seq (bind initial-chars (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   636
		       (bind subsequent-chars (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   637
		       ;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   638
		       (apply spaces)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   639
		       (bind x (apply name-initial initial-chars))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   640
		       (bind xs (many (apply name-subsequent subsequent-chars)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   641
		       (action (string->symbol (list->string (cons x xs))))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   642
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   643
    (name-initial (seq (bind initial-chars (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   644
		       ;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   645
		       (bind c (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   646
		       (action (if (or (char-alphabetic? c)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   647
				       (memv c initial-chars))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   648
				   c
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   649
				   (error 'expected 'name-initial)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   650
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   651
    (name-subsequent (seq (bind subsequent-chars (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   652
			  ;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   653
			  (bind x (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   654
			  (action (if (or (char-alphabetic? x)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   655
					  (char-numeric? x)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   656
					  (memv x subsequent-chars))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   657
				      x
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   658
				      (error 'expected 'name-subsequent)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   659
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   660
    (digit (seq (bind c (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   661
		(action (if (char-numeric? c)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   662
			    c
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   663
			    (error 'expected 'char-numeric?)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   664
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   665
    (spaces (or (seq (many1 (seq (bind c (apply ochar))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   666
				 (action (if (char-whitespace? c)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   667
					     c
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   668
					     (error 'expected 'char-whitespace?)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   669
		     (apply spaces))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   670
		(seq (exactly #\-) (exactly #\-)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   671
		     (many (seq (bind x (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   672
				(action (if (memv x '(#\return #\newline))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   673
					    (error 'expected 'non-eol)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   674
					    x))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   675
		     (apply spaces))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   676
		(action #t)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   677
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   678
    (host-language-expression (apply scheme-term))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   679
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   680
    (scheme-term (or (apply scheme-atom)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   681
		     (apply scheme-quoted "'" 'quote)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   682
		     (apply scheme-quoted "`" 'quasiquote)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   683
		     (apply scheme-quoted "," 'unquote)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   684
		     (apply scheme-quoted ",@" 'unquote-splicing)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   685
		     (seq (apply token "(")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   686
			  (bind xs (apply scheme-sequence))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   687
			  (apply token ")")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   688
			  (action xs))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   689
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   690
    (scheme-quoted (seq (bind quo (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   691
			(bind sym (anything))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   692
			;;
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   693
			(apply spaces)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   694
			(sequence quo)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   695
			(bind x (apply scheme-term))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   696
			(action `(,sym ,x))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   697
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   698
    (scheme-atom (or (apply okeyword "#t" #t)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   699
		     (apply okeyword "#f" #f)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   700
		     (apply onumber)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   701
		     (apply ostring #\")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   702
		     (seq (apply token "#\\")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   703
			  (or (seq (apply token "return") (action #\return))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   704
			      (seq (apply token "newline") (action #\newline))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   705
			      (apply ochar)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   706
		     (apply scheme-symbol)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   707
		     (seq (bind s (apply ostring #\|))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   708
			  (action (string->symbol s)))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   709
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   710
    (scheme-symbol (apply generic-name
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   711
			  '(#\? #\! #\* #\+ #\/ #\= #\: #\< #\>)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   712
			  '(#\? #\! #\* #\+ #\/ #\= #\: #\< #\> #\' #\-)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   713
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   714
    (scheme-sequence (or (seq (bind a (apply scheme-term))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   715
			      (apply token ".")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   716
			      (bind d (apply scheme-term))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   717
			      (action (cons a d)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   718
			 (seq (bind a (apply scheme-term))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   719
			      (bind d (apply scheme-sequence))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   720
			      (action (cons a d)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   721
			 (action '())))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   722
    ))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   723
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   724
(define (serialize-ometa-ast ast)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   725
  (define (emit arg)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   726
    (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   727
     ((null? arg))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   728
     ((pair? arg) (emit (car arg)) (emit (cdr arg)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   729
     (else (display arg))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   730
  (define (xi sep fn args)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   731
    (if (null? args)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   732
	'()
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   733
	(let loop ((args args))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   734
	  (if (null? (cdr args))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   735
	      (fn (car args))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   736
	      (begin (list (fn (car args)) sep (loop (cdr args))))))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   737
  (define (xii op sep fn args cl)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   738
    (list op (xi sep fn args) cl))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   739
  (define (q qch str)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   740
    (list qch (map (lambda (c) (if (eqv? c qch) (list #\\ qch) c)) (string->list str)) qch))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   741
  (define (object->external-representation o)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   742
    (let ((s (open-output-string)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   743
      (write o s)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   744
      (get-output-string s)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   745
  (define (serialize-exp exp)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   746
    (case (car exp)
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   747
      ((apply) (list (cadr exp)
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   748
		     (if (null? (cddr exp))
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   749
			 '()
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   750
			 (xii "(" ", " object->external-representation (cddr exp) ")"))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   751
      ((or) (xii "(" " | " serialize-exp (cdr exp) ")"))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   752
      ((exactly) (let ((ev (cadr exp)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   753
		   (cond
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   754
		    ((null? ev) "nil")
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   755
		    ((eq? #t ev) "true")
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   756
		    ((eq? #f ev) "false")
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   757
		    ((number? ev) (number->string ev))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   758
		    ((string? ev) (q #\' ev))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   759
		    ((char? ev) (list "$" ev))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   760
		    ((symbol? ev) (let ((s (symbol->string ev)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   761
				    (list "#" (if (memv #\' (string->list s))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   762
						  (q #\' s)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   763
						  s))))
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   764
		    (else (error 'serialize-ometa-ast "Invalid literal in (exactly): ~v" ev)))))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   765
      ((sequence) (list "<{"(object->external-representation (cadr exp))"}>"))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   766
      ((nest) (list "{"(serialize-exp (cadr exp))"}"))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   767
      ((not) (list "~"(serialize-exp (cadr exp))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   768
      ((follow) (list "&"(serialize-exp (cadr exp))))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   769
      ((many) (list "("(serialize-exp (cadr exp))")*"))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   770
      ((many1) (list "("(serialize-exp (cadr exp))")+"))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   771
      ((bind) (if (equal? (caddr exp) '(anything))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   772
		  (list ":"(cadr exp))
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   773
		  (list (serialize-exp (caddr exp))":"(cadr exp))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   774
      ((seq) (xi " " serialize-exp (cdr exp)))
1
f6df80d84c79 Push ahead bootstrapping work. Can now parse serialized meta-ometa.
tonyg@lshift.net
parents: 0
diff changeset
   775
      ((anything) "_")
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   776
      ((action) (list "->"(object->external-representation (cadr exp))))
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   777
      (else (error 'serialize-ometa-ast "Bad AST in serialize: ~v" exp))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   778
  (define (serialize-production production)
9
085b12f75c9f Major improvements to ometa syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 8
diff changeset
   779
    (list (car production)" =\n"
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   780
	  (serialize-exp (cadr production))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   781
	  "\n;\n\n"))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   782
  (emit (map serialize-production ast)))
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   783
7
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   784
(define (format-ometa-error err)
37
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   785
  (if err
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   786
      (let ((s (open-output-string)))
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   787
	(display "Parse error at position " s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   788
	(write (car err) s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   789
	(newline s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   790
	(display "Error messages:" s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   791
	(newline s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   792
	(for-each (lambda (msg)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   793
		    (display " - " s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   794
		    (write msg s)
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   795
		    (newline s))
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   796
		  (cdr err))
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   797
	(get-output-string s))
c28094727b3d Cope with no reported error when formatting error messages.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 35
diff changeset
   798
      "No error"))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   799
7
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   800
(define (report-ometa-error err)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   801
  (display (format-ometa-error err))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   802
  (newline)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   803
  (error 'ometa-parse-error))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   804
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   805
(define (parse-ometa input . maybe-error-handler)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   806
  (let ((error-handler (if (null? maybe-error-handler)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   807
			   report-ometa-error
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   808
			   (car maybe-error-handler))))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   809
    (interpret-ometa 'productions (grammar->env meta-ometa) (->input-stream input)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   810
		     (lambda (sv new-env tail err)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   811
		       (if (null? (input-stream->list tail))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   812
			   sv
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   813
			   (error-handler err)))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   814
		     error-handler)))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   815
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   816
(define (parse-ometa-file filename . maybe-error-handler)
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   817
  (call-with-input-file filename
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   818
    (lambda (port)
7
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   819
      (apply parse-ometa (make-port-input-stream filename port) maybe-error-handler))))
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   820
24
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   821
(define ometa-library-path (make-parameter #f))
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   822
10
1d6cc912ec08 Optimise the optimiser using itself.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
   823
(define opt-ometa
24
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   824
  (let ((cache #f))
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   825
    (lambda ()
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   826
      (when (not cache)
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   827
	(set! cache
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   828
	      (let ((opt-ometa-unoptimised
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   829
		     (parse-ometa-file (path->string (build-path (or (ometa-library-path)
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   830
								     (current-directory))
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   831
								 "ometa-opt.g")))))
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   832
		(interpret-ometa 'opt-grammar
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   833
				 (grammar->env opt-ometa-unoptimised)
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   834
				 (->input-stream opt-ometa-unoptimised)
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   835
				 (lambda (sv new-env tail err) sv)
34
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   836
				 (lambda (err) (error 'opt-ometa
ca269f5c30b3 Racketize error reporting a little.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents: 33
diff changeset
   837
						      "Problem optimising optimiser: ~v" err))))))
24
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   838
      cache)))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   839
(define (opt g)
24
105fdea37bc6 Load ometa-opt.g on demand, rather than during compilation.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 23
diff changeset
   840
  (interpret-ometa 'opt-grammar (grammar->env (opt-ometa)) (->input-stream g)
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   841
		   (lambda (sv new-env tail err)
14
08927a2ebac5 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 12
diff changeset
   842
;; 		     (pretty-print `(success (sv ,sv)
08927a2ebac5 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 12
diff changeset
   843
;; 					     (pos ,(input-stream-position tail))
08927a2ebac5 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 12
diff changeset
   844
;; 					     (tail ,(input-stream->list tail))
08927a2ebac5 Apply patch from Simon Michael:
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 12
diff changeset
   845
;; 					     (err ,err)))
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   846
		     sv)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   847
		   (lambda (err)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   848
		     (pretty-print `(failure ,err))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   849
		     err)))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   850
27
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   851
(define (merge-ometa base extension)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   852
  (let* ((merged-productions (map (lambda (base-production)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   853
				    (cond
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   854
				     ((assq (car base-production) extension) =>
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   855
				      (lambda (extension-production)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   856
					`(,(car base-production) (or ,(cadr extension-production)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   857
								     ,(cadr base-production)))))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   858
				     (else
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   859
				      base-production)))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   860
				  base))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   861
	 (missing-productions (fold (lambda (extension-production acc)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   862
				      (cond
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   863
				       ((assq (car extension-production) merged-productions)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   864
					acc)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   865
				       (else
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   866
					(cons extension-production acc))))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   867
				    '()
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   868
				    extension)))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   869
    (opt (append missing-productions merged-productions))))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   870
7
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   871
(define (load-ometa filename . maybe-ometa-parser)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   872
  (let ((grammar (opt ((if (null? maybe-ometa-parser)
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   873
			   parse-ometa-file
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   874
			   (car maybe-ometa-parser)) filename))))
289f2b6b308d Improved error reporting; load ometa-opt.g from same dir as ometa.scm
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 6
diff changeset
   875
    (lambda (start-symbol stream ks kf)
27
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   876
      (simple-ometa-driver grammar start-symbol stream ks kf))))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   877
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   878
(define (simple-ometa-driver grammar start-symbol stream ks kf)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   879
  (interpret-ometa start-symbol (grammar->env grammar) (->input-stream stream)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   880
		   (lambda (sv new-env tail err)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   881
		     (ks sv tail err))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   882
		   (lambda (err)
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   883
		     ;;(pretty-print `(failure ,err))
9302cafa2868 Add merge-ometa, for rudimentary code inheritance
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 26
diff changeset
   884
		     (kf err))))
5
e12fb5f2aad2 Add (load-ometa), for simple testing of parsers
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 4
diff changeset
   885
4
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   886
(define (boot)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   887
  (define (d x)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   888
    (with-output-to-file x
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   889
      (lambda ()
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   890
	(display "-- -*- text -*-")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   891
	(newline)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   892
	(newline)
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   893
	(serialize-ometa-ast meta-ometa))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   894
  (d "m0.g")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   895
  (set! meta-ometa (opt (parse-ometa-file "m0.g")))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   896
  (d "m1.g")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   897
  (set! meta-ometa (opt (parse-ometa-file "m1.g")))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   898
  (d "m2.g")
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   899
  (set! meta-ometa (opt (parse-ometa-file "m2.g"))))
3d59c8de1691 Complete bootstrapping and optimisation
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 3
diff changeset
   900
0
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   901
;;; Local Variables:
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   902
;;; eval: (put 'eval-host 'scheme-indent-function 2)
d1020e9e43c6 A day's hacking
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   903
;;; End: