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