r2/parsetng.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 27 b97df4fc51fb
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
9
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
(define (port-results filename p)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
  (base-generator->results
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
   (let ((ateof #f)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
	 (pos (top-parse-position filename)))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
     (lambda ()
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
       (if ateof
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
	   (values pos #f)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
	   (let ((x (read-char p)))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
	     (if (eof-object? x)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
		 (begin
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
		   (set! ateof #t)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
		   (values pos #f))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
		 (let ((old-pos pos))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
		   (set! pos (update-parse-position pos x))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
		   (values old-pos (cons x x))))))))))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
(define (string-results filename s)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
  (base-generator->results
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
   (let ((idx 0)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
	 (len (string-length s))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
	 (pos (top-parse-position filename)))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
     (lambda ()
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
       (if (= idx len)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
	   (values pos #f)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
	   (let ((x (string-ref s idx))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
		 (old-pos pos))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
	     (set! pos (update-parse-position pos x))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
	     (set! idx (+ idx 1))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
	     (values old-pos (cons x x))))))))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
(define (parse-result->value error-text result)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
  (if (parse-result-successful? result)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
      (parse-result-semantic-value result)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
      (error error-text
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
	     (let ((e (parse-result-error result)))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
	       (list error-text
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
		     (parse-position->string (parse-error-position e))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
		     (parse-error-expected e)
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
		     (parse-error-messages e))))))
8d6763fa7838 Start on TNG2 reader.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
13
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    41
(define (packrat-token str)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    42
  (lambda (starting-results)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    43
    (let loop ((pos 0) (results starting-results))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    44
      (if (= pos (string-length str))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    45
	  (make-result str results)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    46
	  (if (and results (char=? (parse-results-token-value results) (string-ref str pos)))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    47
	      (loop (+ pos 1) (parse-results-next results))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    48
	      (make-expected-result (parse-results-position starting-results) str))))))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    49
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    50
(define (parse-results-take results n)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    51
  (let loop ((acc '())
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    52
	     (results results)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    53
	     (n n))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    54
    (if (zero? n)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    55
	(values (list->string (reverse acc))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    56
		results)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    57
	(loop (cons (parse-results-token-value results) acc)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    58
	      (parse-results-next results)
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    59
	      (- n 1)))))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    60
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    61
(define (parse-results->pregexp-stream results)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    62
  (pregexp-make-stream (lambda (r)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    63
			 (if r
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    64
			     (cons (parse-results-token-value r)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    65
				   (parse-results-next r))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    66
			     (cons #f #f)))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    67
		       results))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    68
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
    69
(define (packrat-regex name . string-fragments)
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
    70
  (let* ((exp (string-concatenate string-fragments))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
    71
	 (re (pregexp exp)))
13
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    72
    (lambda (results)
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    73
      (let* ((stream (parse-results->pregexp-stream results))
13
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    74
	     (match (pregexp-match-head re stream)))
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    75
	(if match
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    76
	    (let-values (((str next) (parse-results-take results (cdar match))))
13
01102c5aa237 Sketch out code for regex tokenising. (Untested so far)
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 9
diff changeset
    77
	      (make-result str next))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
    78
	    (make-expected-result (parse-results-position results) name))))))
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    79
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    80
(define (packrat-cache key parser)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    81
  (lambda (results)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    82
    (results->result results key
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    83
		     (lambda ()
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    84
		       (parser results)))))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    85
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    86
(define-syntax define-packrat-cached
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    87
  (syntax-rules ()
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    88
    ((_ (fnname results) body ...)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    89
     (define fnname
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    90
       (packrat-cache 'fnname
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    91
		      (letrec ((fnname (lambda (results) body ...)))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    92
			fnname))))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    93
    ((_ fnname exp)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    94
     (define fnname
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    95
       (packrat-cache 'fnname exp)))))
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
    96
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
    97
(define-values (parse-ThiNG parse-ThiNG-toplevel)
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
    98
  (let* ((p "[-+=_|/?.<>*&^%$#@!`~]")
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
    99
	 (midsym (string-append "([a-zA-Z0-9]|"p")")))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   100
    (packrat-parser (begin
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   101
		      (define-packrat-cached (white results)
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   102
			(if (and-let* ((ch (parse-results-token-value results)))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   103
			      (char-whitespace? ch))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   104
			    (white (parse-results-next results))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   105
			    (comment results)))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   106
		      (define-packrat-cached (comment results)
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   107
			(if (eq? (parse-results-token-value results) #\")
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   108
			    (skip-comment-body (parse-results-next results))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   109
			    (make-result 'whitespace results)))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   110
		      (define (skip-comment-body results)
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   111
			(if (eq? (parse-results-token-value results) #\")
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   112
			    (white (parse-results-next results))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   113
			    (skip-comment-body (parse-results-next results))))
19
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   114
		      (define (string-body results)
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   115
			(string-body* results '()))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   116
		      (define (string-body* results acc)
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   117
			(let ((ch (parse-results-token-value results))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   118
			      (next (parse-results-next results)))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   119
			  (if (eq? ch #\')
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   120
			      (string-body-quote next acc)
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   121
			      (string-body* next (cons ch acc)))))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   122
		      (define (string-body-quote results acc)
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   123
			(if (eq? (parse-results-token-value results) #\')
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   124
			    (string-body* (parse-results-next results) (cons #\' acc))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   125
			    (make-result (list->string (reverse acc)) results)))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   126
		      (define-packrat-cached atom (packrat-regex 'atom "[A-Z]"midsym"*"))
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   127
		      (define-packrat-cached var (packrat-regex 'var "[a-z]"midsym"*"))
18
90f6fc611219 Rationalise infixop syntax.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 17
diff changeset
   128
		      (define-packrat-cached infixop-raw (packrat-regex 'infixop p midsym"*"))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   129
		      (define-packrat-cached integer (packrat-regex 'integer "[0-9]+"))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   130
		      (define (make-binary op left right)
27
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   131
			`(adj ,op (tuple ,left ,right)))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   132
		      (values tuple1 toplevel))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   133
		    (toplevel ((d <- tuple1 white '#\; '#\;) d)
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   134
			      ((white '#f) `(atom |Quit|)))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   135
		    (datum ((s <- tuple0) s))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   136
		    (tuple0 ((s <- tuple1) s)
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   137
			    (() '(tuple)))
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   138
		    (tuple1 ((s <- tuple1*) (if (= (length s) 2) (cadr s) s)))
19
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   139
		    (tuple1* ((d <- fun white '#\, s <- tuple1*) `(tuple ,d ,@(cdr s)))
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   140
			     ((d <- fun) `(tuple ,d)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   141
		    (fun ((f <- fun*) f)
27
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   142
			 ((v <- funcall f <- fun*) `(adj ,v (quote ,f)))
19
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   143
			 ((v <- funcall) v))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   144
		    (fun* ((e <- entry white d <- fun*) `(fun ,e ,@(cdr d)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   145
			  ((e <- entry) `(fun ,e)))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   146
		    (entry ((k <- simple colon v <- funcall) (list k v)))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   147
		    (semi ((white '#\; (! '#\;)) 'semi))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   148
		    (colon ((white '#\:) 'colon))
27
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   149
		    (funcall ((a <- adj f <- funcall*) (f a)))
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   150
		    (funcall* ((o <- infixop b <- adj f <- funcall*)
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   151
			          (lambda (a) (f (make-binary o a b))))
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   152
			      (() (lambda (a) a)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   153
		    (infixop ((white r <- infixop-raw) `(var ,(string->symbol r))))
27
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   154
		    (adj ((left <- adj-leaf f <- adj-tail) (f left)))
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   155
		    (adj-tail ((white right <- adj-leaf f <- adj-tail)
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   156
			          (lambda (left) (f `(adj ,left ,right))))
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   157
			      (() (lambda (left) left)))
b97df4fc51fb Simplify adjacency parsing
Tony Garnock-Jones <tonyg@lshift.net>
parents: 21
diff changeset
   158
		    (adj-leaf ((v <- simple (! colon)) v))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   159
		    (simple ((white d1 <- simple1) d1))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   160
		    (simple1 (('#\( o <- infixop white '#\)) o)
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   161
			     (('#\( d <- datum white '#\)) d)
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   162
			     (('#\[ d <- datum white '#\]) `(quote ,d))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   163
			     (('#\{ d <- datum white '#\}) `(meta-quote ,d))
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   164
			     ((l <- literal) `(lit ,l))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   165
			     ((a <- var) `(var ,(string->symbol a)))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   166
			     ((a <- atom) `(atom ,(string->symbol a)))
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   167
			     (('#\' s <- string-body) `(atom ,(string->symbol s)))
17
f85405ebe671 Further work on the parser.
Tony Garnock-Jones <tonyg@lshift.net>
parents: 16
diff changeset
   168
			     (('#\_) `(discard)))
19
1526bbb83c0c String literals, negative int literals, better error handling
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 18
diff changeset
   169
		    (literal ((i <- integer) (string->number i))
20
9b9bd39d5e13 Lots of work. Simple evaluator.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 19
diff changeset
   170
			     (('#\- i <- integer) (- (string->number i)))))))
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   171
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   172
(define read-ThiNG
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   173
  (lambda ()
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   174
    (parse-result->value "While parsing ThiNG"
16
056c2d4dcf13 Flesh out parser.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents: 14
diff changeset
   175
			 (parse-ThiNG-toplevel (port-results "stdin" (current-input-port))))))
14
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   176
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   177
(define string->ThiNG
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   178
  (lambda (s)
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   179
    (parse-result->value "While parsing ThiNG"
660f8ee0496c Further work on the parser
Tony Garnock-Jones <tonyg@lshift.net>
parents: 13
diff changeset
   180
			 (parse-ThiNG (string-results "<string>" s)))))