ometa-scheme
changeset 1:f6df80d84c79
Push ahead bootstrapping work. Can now parse serialized meta-ometa.
| author | tonyg@lshift.net |
|---|---|
| date | Thu May 22 00:54:49 2008 +0100 (2008-05-22) |
| parents | d1020e9e43c6 |
| children | 750cff2fd084 |
| files | ometa-boot.g ometa.scm |
line diff
1.1 --- a/ometa-boot.g Wed Jan 23 21:49:28 2008 +0000 1.2 +++ b/ometa-boot.g Thu May 22 00:54:49 2008 +0100 1.3 @@ -1,100 +1,101 @@ 1.4 -- -*- text -*- 1.5 1.6 productions ::= 1.7 - (<production>)+ 1.8 +(<(production)>)+ 1.9 ; 1.10 1.11 production ::= 1.12 - &<name>:n 1.13 - <production-part n>:x (<token ";"> <production-part n>)*:xs <token ";"> 1.14 - <spaces> => #<procedure:...scheme/ometa.scm:467:32> 1.15 +&<(name)>:n <(production-part n)>:x (<(token ";")> <(production-part n)>)*:xs <(token ";")> <(spaces)> =>(quasiquote ((unquote n) seq (unquote x) (unquote-splicing xs))) 1.16 ; 1.17 1.18 production-part ::= 1.19 -ANYTHING:required-name <name>:n =>#<procedure:...scheme/ometa.scm:473:37> <expr-seq>:body (<token "::="> <expr>:rhs =>#<procedure:...scheme/ometa.scm:478:46> | =>#<procedure:...scheme/ometa.scm:480:41>) 1.20 +:required-name <(name)>:n =>(or (eq? n required-name) (error (quote clause-name-mismatch))) <(expr-seq)>:body (<(token "::=")> <(expr)>:rhs =>(quasiquote (seq (unquote body) (unquote rhs))) | =>body) 1.21 ; 1.22 1.23 expr-seq ::= 1.24 -(<expr3>)*:xs =>#<procedure:...scheme/ometa.scm:483:30> 1.25 +(<(expr3)>)*:xs =>(quasiquote (seq (unquote-splicing xs))) 1.26 ; 1.27 1.28 expr3 ::= 1.29 -(<expr2>:r (<token "*"> =>#<procedure:...scheme/ometa.scm:486:66> | <token "+"> =>#<procedure:...scheme/ometa.scm:487:66> | =>#<procedure:...scheme/ometa.scm:488:43>):r ($: <name>:n =>#<procedure:...scheme/ometa.scm:490:40> | =>#<procedure:...scheme/ometa.scm:491:35>) | <token ":"> <name>:n =>#<procedure:...scheme/ometa.scm:493:31>) 1.30 +(<(expr2)>:r (<(token "*")> =>(quasiquote (many (unquote r))) | <(token "+")> =>(quasiquote (many1 (unquote r))) | =>r):r ($: <(name)>:n =>(quasiquote (bind (unquote n) (unquote r))) | =>r) | <(token ":")> <(name)>:n =>(quasiquote (bind (unquote n) (anything)))) 1.31 ; 1.32 1.33 expr2 ::= 1.34 -(<token "~"> <expr2>:x =>#<procedure:...scheme/ometa.scm:496:31> | <token "&"> <expr1>:x =>#<procedure:...scheme/ometa.scm:498:31> | <expr1>) 1.35 +(<(token "~")> <(expr2)>:x =>(quasiquote (not (unquote x))) | <(token "&")> <(expr1)>:x =>(quasiquote (follow (unquote x))) | <(expr1)>) 1.36 ; 1.37 1.38 expr1 ::= 1.39 -(<token "<"> <name>:prod (~<token ">"> <host-language-expression>)*:args <token ">"> =>#<procedure:...scheme/ometa.scm:505:31> | <token "=>"> <host-language-expression>:r =>#<procedure:...scheme/ometa.scm:507:31> | <token "!"> <host-language-expression>:r =>#<procedure:...scheme/ometa.scm:509:31> | <token "?"> <host-language-expression>:r =>#<procedure:...scheme/ometa.scm:511:31> | <literal>:x =>#<procedure:...scheme/ometa.scm:513:31> | <ostring #\">:str =>#<procedure:...scheme/ometa.scm:515:31> | <token "("> <expr>:x <token ")"> =>#<procedure:...scheme/ometa.scm:519:31> | <token "{"> <expr-seq>:xs <token "}"> =>#<procedure:...scheme/ometa.scm:521:31>) 1.40 +(<(token "<{")> <(host-language-expression)>:s <(token "}>")> =>(quasiquote (sequence (unquote s))) | <(token "<(")> <(scheme-sequence)>:exps <(token ")>")> =>(quasiquote (apply (unquote-splicing exps))) | <(token "=>")> <(host-language-expression)>:r =>(quasiquote (action (unquote r))) | <(literal)>:x =>(quasiquote (exactly (unquote x))) | <(token "_")> =>(quasiquote (anything)) | <(token "(")> <(expr)>:x <(token ")")> =>x | <(token "{")> <(expr-seq)>:xs <(token "}")> =>(quasiquote (nest (unquote xs)))) 1.41 ; 1.42 1.43 literal ::= 1.44 -(<okeyword "nil" ()> | <okeyword "true" #t> | <okeyword "false" #f> | <onumber> | <ostring #\'> | <token "$"> <ochar> | <token "#"> (<name> | <ostring #\'>:s =>#<procedure:...scheme/ometa.scm:531:60>)) 1.45 +(<(okeyword "nil" ())> | <(okeyword "true" #t)> | <(okeyword "false" #f)> | <(onumber)> | <(ostring #\')> | <(token "$")> <(ochar)> | <(token "#")> (<(name)> | <(ostring #\')>:s =>(string->symbol s))) 1.46 ; 1.47 1.48 onumber ::= 1.49 -<spaces> (<digit>)+:ip ($. (<digit>)+:fp =>#<procedure:...scheme/ometa.scm:536:38> | =>#<procedure:...scheme/ometa.scm:540:33>) 1.50 +<(spaces)> (<(digit)>)+:ip ($. (<(digit)>)+:fp =>(string->number (string-append (list->string ip) "." (list->string fp))) | =>(string->number (list->string ip))) 1.51 ; 1.52 1.53 ostring ::= 1.54 -<ochar>:quo <spaces> CHECK===<ochar>::string-open-quote (($\ ($\ | CHECK===<ochar>::escaped-quote) | CHECK===<ochar>::string-char))*:cs CHECK===<ochar>::string-close-quote =>#<procedure:...scheme/ometa.scm:555:29> 1.55 +<(ochar)>:quo <(spaces)> <(ochar)>:s1 =>(or (eqv? s1 quo) (error (quote expected) (quote string-open-quote))) (($\ ($\ | <(ochar)>:c =>(if (eqv? c quo) c (error (quote expected) (quote escaped-quote)))) | <(ochar)>:c =>(if (eqv? c quo) (error (quote expected) (quote string-char)) c)))*:cs <(ochar)>:s2 =>(if (eqv? s2 quo) (list->string cs) (error (quote expected) (quote string-close-quote))) 1.56 ; 1.57 1.58 ochar ::= 1.59 -CHECK===ANYTHING::char? 1.60 +:c =>(if (char? c) c (error (quote expected) (quote char?))) 1.61 ; 1.62 1.63 expr ::= 1.64 -<expr-seq>:x (<token "|"> <expr-seq>)*:xs =>#<procedure:...scheme/ometa.scm:561:26> 1.65 +<(expr-seq)>:x (<(token "|")> <(expr-seq)>)*:xs =>(quasiquote (or (unquote x) (unquote-splicing xs))) 1.66 +; 1.67 + 1.68 +okeyword ::= 1.69 +:xs :val <(spaces)> <{xs}> ~<(name-subsequent (quote (#\- #\? #\! #\* #\+ #\/ #\= #\: #\')))> =>val 1.70 +; 1.71 + 1.72 +token ::= 1.73 +:xs <(spaces)> <{xs}> 1.74 ; 1.75 1.76 name ::= 1.77 -<spaces> <name-initial>:x (<name-subsequent>)*:xs =>#<procedure:...scheme/ometa.scm:566:26> 1.78 +<(generic-name (quote (#\- #\? #\! #\* #\+ #\/ #\= #\: #\')))> 1.79 ; 1.80 1.81 -okeyword ::= 1.82 -ANYTHING:xs ANYTHING:val <spaces> SEQ===xs ~<name-subsequent> =>#<procedure:...scheme/ometa.scm:573:30> 1.83 -; 1.84 - 1.85 -token ::= 1.86 -ANYTHING:xs <spaces> SEQ===xs 1.87 +generic-name ::= 1.88 +:subsequent-chars <(spaces)> <(name-initial)>:x (<(name-subsequent subsequent-chars)>)*:xs =>(string->symbol (list->string (cons x xs))) 1.89 ; 1.90 1.91 name-initial ::= 1.92 -CHECK===<ochar>::char-alphabetic? 1.93 +<(ochar)>:c =>(if (char-alphabetic? c) c (error (quote expected) (quote char-alphabetic?))) 1.94 ; 1.95 1.96 name-subsequent ::= 1.97 -CHECK===<ochar>::name-subsequent 1.98 +:subsequent-chars <(ochar)>:x =>(if (or (char-alphabetic? x) (char-numeric? x) (memv x subsequent-chars)) x (error (quote expected) (quote name-subsequent))) 1.99 ; 1.100 1.101 digit ::= 1.102 -CHECK===<ochar>::char-numeric? 1.103 +<(ochar)>:c =>(if (char-numeric? c) c (error (quote expected) (quote char-numeric?))) 1.104 ; 1.105 1.106 spaces ::= 1.107 - | $ 1.108 -) <spaces> | =>#<procedure:...scheme/ometa.scm:595:27>) 1.109 +((<(ochar)>:c =>(if (char-whitespace? c) c (error (quote expected) (quote char-whitespace?))))+ <(spaces)> | $- $- (:x =>(if (memv x (quote (#\return #\newline))) (error (quote expected) (quote non-eol)) x))* <(spaces)> | =>#t) 1.110 ; 1.111 1.112 host-language-expression ::= 1.113 -<scheme-term> 1.114 +<(scheme-term)> 1.115 ; 1.116 1.117 scheme-term ::= 1.118 -(<scheme-atom> | <scheme-quoted "'" (quote quote)> | <scheme-quoted "`" (quote quasiquote)> | <scheme-quoted "," (quote unquote)> | <scheme-quoted ",@" (quote unquote-splicing)> | <token "("> <scheme-sequence>:xs <token ")"> =>#<procedure:...scheme/ometa.scm:607:37>) 1.119 +(<(scheme-atom)> | <(scheme-quoted "'" (quote quote))> | <(scheme-quoted "`" (quote quasiquote))> | <(scheme-quoted "," (quote unquote))> | <(scheme-quoted ",@" (quote unquote-splicing))> | <(token "(")> <(scheme-sequence)>:xs <(token ")")> =>xs) 1.120 ; 1.121 1.122 scheme-quoted ::= 1.123 -ANYTHING:quo ANYTHING:sym <spaces> SEQ===quo <scheme-term>:x =>#<procedure:...scheme/ometa.scm:615:35> 1.124 +:quo :sym <(spaces)> <{quo}> <(scheme-term)>:x =>(quasiquote ((unquote sym) (unquote x))) 1.125 ; 1.126 1.127 scheme-atom ::= 1.128 -(<okeyword "#t" #t> | <okeyword "#f" #f> | <onumber> | <ostring #\"> | <token "#\\"> <ochar> | <name> | <ostring #\|>:s =>#<procedure:...scheme/ometa.scm:624:37>) 1.129 +(<(okeyword "#t" #t)> | <(okeyword "#f" #f)> | <(onumber)> | <(ostring #\")> | <(token "#\\")> <(ochar)> | <(generic-name (quote (#\- #\? #\! #\* #\+ #\/ #\= #\: #\' #\< #\>)))> | <(ostring #\|)>:s =>(string->symbol s)) 1.130 ; 1.131 1.132 scheme-sequence ::= 1.133 -(<scheme-term>:a <token "."> <scheme-term>:d =>#<procedure:...scheme/ometa.scm:629:41> | <scheme-term>:a <scheme-sequence>:d =>#<procedure:...scheme/ometa.scm:632:41> | =>#<procedure:...scheme/ometa.scm:633:36>) 1.134 +(<(scheme-term)>:a <(token ".")> <(scheme-term)>:d =>(cons a d) | <(scheme-term)>:a <(scheme-sequence)>:d =>(cons a d) | =>(quote ())) 1.135 ;
2.1 --- a/ometa.scm Wed Jan 23 21:49:28 2008 +0000 2.2 +++ b/ometa.scm Thu May 22 00:54:49 2008 +0100 2.3 @@ -209,57 +209,6 @@ 2.4 2.5 ;; The result of parsing is either (semantic-value * new-env * next * error) or (error) 2.6 2.7 -(define-syntax ometa-lambda 2.8 - (syntax-rules () 2.9 - ((_ (binding ...) body ...) 2.10 - (ometa-lambda* succeed fail (binding ...) 2.11 - (let ((value (begin body ...))) 2.12 - (succeed value)))))) 2.13 - 2.14 -(define-syntax ometa-error 2.15 - (syntax-rules () 2.16 - ((_ (binding ...) body ...) 2.17 - (ometa-lambda* succeed fail (binding ...) 2.18 - (let ((error-report (begin body ...))) 2.19 - (fail error-report)))))) 2.20 - 2.21 -(define-syntax ometa-predicate 2.22 - (syntax-rules () 2.23 - ((_ name (binding ...) body0 body ...) 2.24 - (ometa-lambda* succeed fail (binding ...) 2.25 - ;;(pretty-print `(predicate ,'name (,binding ...))) 2.26 - (if (begin body0 body ...) 2.27 - (succeed #t) 2.28 - (fail `(expected name))))) 2.29 - ((_ name binding ...) 2.30 - (ometa-predicate name (binding ...) (name binding ...))))) 2.31 - 2.32 -(define-syntax ometa-lambda* 2.33 - (syntax-rules () 2.34 - ((_ succeed fail (binding ...) body ...) 2.35 - (lambda (env input ks kf) 2.36 - (let ((succeed (lambda (value) (ks value env input #f))) 2.37 - (fail (lambda (error-report) 2.38 - (kf (make-parse-error (input-stream-position input) error-report)))) 2.39 - (binding (cond ((assq 'binding env) => cddr) 2.40 - (else (error "Missing binding" 'binding)))) 2.41 - ...) 2.42 - body ...))))) 2.43 - 2.44 -(define-syntax ometa-checker 2.45 - (syntax-rules () 2.46 - ((_ predicate parser) 2.47 - `(check parser predicate 2.48 - ,(lambda (sv env input) 2.49 - (predicate sv)))) 2.50 - ((_ name parser (sv binding ...) body0 body ...) 2.51 - `(check parser name 2.52 - ,(lambda (sv env input) 2.53 - (let ((binding (cond ((assq 'binding env) => cddr) 2.54 - (else (error "Missing binding" 'binding)))) 2.55 - ...) 2.56 - body0 body ...)))))) 2.57 - 2.58 ;; (apply production-name arg ...) ; both name and arg may be variables; args implicit - pushed on the input stream! 2.59 ;; (or parser ...) 2.60 ;; (exactly datum) ; nil true false <number> 'string' #symbol $c "sequence of chars" 2.61 @@ -273,8 +222,8 @@ 2.62 ;; (bind name parser) 2.63 ;; (seq parser ...) 2.64 ;; (anything) 2.65 -;; (check parser name fn) 2.66 -;; (action fn); => exp, !exp, ?exp 2.67 +;; (check parser name meta-exp) 2.68 +;; (action meta-exp); => exp, !exp, ?exp 2.69 2.70 (define (interpret-ometa start rules input ks kf) 2.71 (define (eval-host exp env k) 2.72 @@ -314,10 +263,36 @@ 2.73 '() 2.74 (cons (car env) (nonshared-env (cdr env))))) 2.75 2.76 + (define (nonshared-env-values env) 2.77 + (if (eq? env rules) 2.78 + '() 2.79 + (cons (cddar env) (nonshared-env-values (cdr env))))) 2.80 + 2.81 + (define (nonshared-env-names env) 2.82 + (let loop ((env env) 2.83 + (acc '())) 2.84 + (cond 2.85 + ((eq? env rules) (reverse acc)) 2.86 + ((memq (caar env) acc) (loop (cdr env) (cons (gensym) acc))) 2.87 + (else (loop (cdr env) (cons (caar env) acc)))))) 2.88 + 2.89 + (define (compile-meta-exp exp compile-time-env) 2.90 + (let ((success-sym (gensym)) 2.91 + (names (nonshared-env-names compile-time-env))) 2.92 + (let ((source-form `(lambda (,success-sym error ,@names) 2.93 + (,success-sym ,exp)))) 2.94 + (pretty-print `((source-form ,source-form)))(newline) 2.95 + (eval source-form)))) 2.96 + 2.97 (define memo-tab (make-hash-table equal?)) 2.98 2.99 (define (e exp env input ks kf) 2.100 - ;;(pretty-print `((exp ,exp) (env ,(nonshared-env env) (input ,(input-stream->list input))))) 2.101 +;; (pretty-print `( 2.102 +;; ;;(exp ,exp) 2.103 +;; ;;(env ,(nonshared-env env)) 2.104 +;; ;;(input ,(input-stream->list input)) 2.105 +;; (pos ,(input-stream-position input)) 2.106 +;; )) 2.107 (case (car exp) 2.108 ((apply) 2.109 (eval-host (cadr exp) env 2.110 @@ -433,19 +408,24 @@ 2.111 ((anything) 2.112 (input (lambda (pos item tail) (ks item env tail #f)) 2.113 (lambda (pos) (kf (make-parse-error pos 'end-of-stream))))) 2.114 - ((check) 2.115 - (e (cadr exp) env input 2.116 - (lambda (sv new-env next err) 2.117 - (let ((name (caddr exp)) 2.118 - (fn (cadddr exp))) 2.119 - (if (fn sv new-env input) 2.120 - (ks sv new-env next err) 2.121 - (kf (merge-parse-errors (make-parse-error (input-stream-position input) 2.122 - `(expected ,name)) 2.123 - err))))) 2.124 - kf)) 2.125 ((action) 2.126 - ((cadr exp) env input ks kf)) 2.127 + (let* ((fn (if (null? (cddr exp)) 2.128 + (let ((v (compile-meta-exp (cadr exp) env))) 2.129 + (set-cdr! (cdr exp) (list v)) 2.130 + v) 2.131 + (caddr exp))) 2.132 + (escape '*) 2.133 + (escaped (call-with-current-continuation 2.134 + (lambda (set-escaped!) 2.135 + (set! escape (lambda error-report 2.136 + (set-escaped! error-report))) 2.137 + #f)))) 2.138 + (if escaped 2.139 + (kf (make-parse-error (input-stream-position input) escaped)) 2.140 + (apply fn 2.141 + (lambda (sv) (ks sv env input #f)) 2.142 + escape 2.143 + (nonshared-env-values env))))) 2.144 (else (error "Bad OMeta AST" exp)))) 2.145 2.146 (e `(apply ,start) rules input 2.147 @@ -464,61 +444,57 @@ 2.148 (apply production-part n)))) 2.149 (apply token ";") 2.150 (apply spaces) 2.151 - (action ,(ometa-lambda (n x xs) 2.152 - `(,n . (seq ,x ,@xs)))))) 2.153 + (action `(,n . (seq ,x ,@xs))))) 2.154 2.155 (production-part . (seq (bind required-name (anything)) 2.156 ;; 2.157 (bind n (apply name)) 2.158 - (action ,(ometa-predicate clause-names-match (n required-name) 2.159 - (eq? n required-name))) 2.160 + (action (or (eq? n required-name) 2.161 + (error 'clause-name-mismatch))) 2.162 (bind body (apply expr-seq)) 2.163 (or (seq (apply token "::=") 2.164 (bind rhs (apply expr)) 2.165 - (action ,(ometa-lambda (body rhs) 2.166 - `(seq ,body ,rhs)))) 2.167 - (action ,(ometa-lambda (body) body))))) 2.168 + (action `(seq ,body ,rhs))) 2.169 + (action body)))) 2.170 2.171 (expr-seq . (seq (bind xs (many (apply expr3))) 2.172 - (action ,(ometa-lambda (xs) `(seq ,@xs))))) 2.173 + (action `(seq ,@xs)))) 2.174 2.175 (expr3 . (or (seq (bind r (apply expr2)) 2.176 - (bind r (or (seq (apply token "*") (action ,(ometa-lambda (r) `(many ,r)))) 2.177 - (seq (apply token "+") (action ,(ometa-lambda (r) `(many1 ,r)))) 2.178 - (action ,(ometa-lambda (r) r)))) 2.179 + (bind r (or (seq (apply token "*") (action `(many ,r))) 2.180 + (seq (apply token "+") (action `(many1 ,r))) 2.181 + (action r))) 2.182 (or (seq (exactly #\:) (bind n (apply name)) 2.183 - (action ,(ometa-lambda (r n) `(bind ,n ,r)))) 2.184 - (action ,(ometa-lambda (r) r)))) 2.185 + (action `(bind ,n ,r))) 2.186 + (action r))) 2.187 (seq (apply token ":") (bind n (apply name)) 2.188 - (action ,(ometa-lambda (n) `(bind ,n (anything))))))) 2.189 + (action `(bind ,n (anything)))))) 2.190 2.191 (expr2 . (or (seq (apply token "~") (bind x (apply expr2)) 2.192 - (action ,(ometa-lambda (x) `(not ,x)))) 2.193 + (action `(not ,x))) 2.194 (seq (apply token "&") (bind x (apply expr1)) 2.195 - (action ,(ometa-lambda (x) `(follow ,x)))) 2.196 + (action `(follow ,x))) 2.197 (apply expr1))) 2.198 2.199 - (expr1 . (or (seq (apply token "<") (bind prod (apply name)) 2.200 - (bind args (many (seq (not (apply token ">")) 2.201 - (apply host-language-expression)))) 2.202 - (apply token ">") 2.203 - (action ,(ometa-lambda (prod args) `(apply ,prod ,@args)))) 2.204 + (expr1 . (or (seq (apply token "<{") 2.205 + (bind s (apply host-language-expression)) 2.206 + (apply token "}>") 2.207 + (action `(sequence ,s))) 2.208 + (seq (apply token "<(") 2.209 + (bind exps (apply scheme-sequence)) ;; production arg ... 2.210 + (apply token ")>") 2.211 + (action `(apply ,@exps))) 2.212 (seq (apply token "=>") (bind r (apply host-language-expression)) 2.213 - (action ,(ometa-lambda (r) `(unfinished-action ,r)))) 2.214 - (seq (apply token "!") (bind r (apply host-language-expression)) 2.215 - (action ,(ometa-lambda (r) `(unfinished-action ,r)))) 2.216 - (seq (apply token "?") (bind r (apply host-language-expression)) 2.217 - (action ,(ometa-lambda (r) `(unfinished-predicate ,r)))) 2.218 + (action `(action ,r))) 2.219 +;; (seq (apply token "?") (bind r (apply host-language-expression)) 2.220 +;; (action `(unfinished-predicate ,r))) 2.221 (seq (bind x (apply literal)) 2.222 - (action ,(ometa-lambda (x) `(exactly ,x)))) 2.223 - (seq (bind str (apply ostring #\")) 2.224 - (action ,(ometa-lambda (str) 2.225 - `(seq ,@(map (lambda (c) `(exactly ,c)) (string->list str)) 2.226 - (unfinished-action str))))) 2.227 + (action `(exactly ,x))) 2.228 + (seq (apply token "_") (action `(anything))) 2.229 (seq (apply token "(") (bind x (apply expr)) (apply token ")") 2.230 - (action ,(ometa-lambda (x) x))) 2.231 + (action x)) 2.232 (seq (apply token "{") (bind xs (apply expr-seq)) (apply token "}") 2.233 - (action ,(ometa-lambda (xs) `(nest ,xs)))))) 2.234 + (action `(nest ,xs))))) 2.235 2.236 (literal . (or (apply okeyword "nil" ()) 2.237 (apply okeyword "true" #t) 2.238 @@ -528,71 +504,96 @@ 2.239 (seq (apply token "$") (apply ochar)) 2.240 (seq (apply token "#") (or (apply name) 2.241 (seq (bind s (apply ostring #\')) 2.242 - (action ,(ometa-lambda (s) 2.243 - (string->symbol s)))))))) 2.244 + (action (string->symbol s))))))) 2.245 2.246 (onumber . (seq (apply spaces) (bind ip (many1 (apply digit))) 2.247 (or (seq (exactly #\.) (bind fp (many1 (apply digit))) 2.248 - (action ,(ometa-lambda (ip fp) 2.249 - (string->number (string-append (list->string ip) 2.250 - "." 2.251 - (list->string fp)))))) 2.252 - (action ,(ometa-lambda (ip) 2.253 - (string->number (list->string ip))))))) 2.254 + (action (string->number (string-append (list->string ip) 2.255 + "." 2.256 + (list->string fp))))) 2.257 + (action (string->number (list->string ip)))))) 2.258 2.259 (ostring . (seq (bind quo (apply ochar)) 2.260 ;; 2.261 (apply spaces) 2.262 - ,(ometa-checker string-open-quote (apply ochar) (s1 quo) (eqv? s1 quo)) 2.263 + (bind s1 (apply ochar)) 2.264 + (action (or (eqv? s1 quo) (error 'expected 'string-open-quote))) 2.265 (bind cs (many (or (seq (exactly #\\) 2.266 (or (exactly #\\) 2.267 - ,(ometa-checker escaped-quote (apply ochar) (c quo) 2.268 - (pretty-print (list c quo)) 2.269 - (eqv? c quo)))) 2.270 - ,(ometa-checker string-char (apply ochar) (c quo) 2.271 - (not (eqv? c quo)))))) 2.272 - ,(ometa-checker string-close-quote (apply ochar) (s2 quo) (eqv? s2 quo)) 2.273 - (action ,(ometa-lambda (cs) (list->string cs))))) 2.274 + (seq (bind c (apply ochar)) 2.275 + (action (if (eqv? c quo) 2.276 + c 2.277 + (error 'expected 2.278 + 'escaped-quote)))))) 2.279 + (seq (bind c (apply ochar)) 2.280 + (action (if (eqv? c quo) 2.281 + (error 'expected 'string-char) 2.282 + c)))))) 2.283 + (bind s2 (apply ochar)) 2.284 + (action (if (eqv? s2 quo) 2.285 + (list->string cs) 2.286 + (error 'expected 'string-close-quote))))) 2.287 2.288 - (ochar . ,(ometa-checker char? (anything))) 2.289 + (ochar . (seq (bind c (anything)) 2.290 + (action (if (char? c) 2.291 + c 2.292 + (error 'expected 'char?))))) 2.293 2.294 (expr . (seq (bind x (apply expr-seq)) 2.295 (bind xs (many (seq (apply token "|") (apply expr-seq)))) 2.296 - (action ,(ometa-lambda (x xs) `(or ,x ,@xs))))) 2.297 - 2.298 - (name . (seq (apply spaces) 2.299 - (bind x (apply name-initial)) 2.300 - (bind xs (many (apply name-subsequent))) 2.301 - (action ,(ometa-lambda (x xs) (string->symbol (list->string (cons x xs))))))) 2.302 + (action `(or ,x ,@xs)))) 2.303 2.304 (okeyword . (seq (bind xs (anything)) 2.305 (bind val (anything)) 2.306 ;; 2.307 (apply spaces) (sequence xs) 2.308 - (not (apply name-subsequent)) 2.309 - (action ,(ometa-lambda (xs val) val)))) 2.310 + (not (apply name-subsequent '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\'))) 2.311 + (action val))) 2.312 2.313 (token . (seq (bind xs (anything)) 2.314 ;; 2.315 (apply spaces) (sequence xs))) 2.316 2.317 - (name-initial . ,(ometa-checker char-alphabetic? (apply ochar))) 2.318 + (name . (apply generic-name '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\'))) 2.319 2.320 - (name-subsequent . ,(ometa-checker name-subsequent (apply ochar) (x) 2.321 - (or (char-alphabetic? x) 2.322 - (char-numeric? x) 2.323 - (memv x '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\'))))) 2.324 + (generic-name . (seq (bind subsequent-chars (anything)) 2.325 + ;; 2.326 + (apply spaces) 2.327 + (bind x (apply name-initial)) 2.328 + (bind xs (many (apply name-subsequent subsequent-chars))) 2.329 + (action (string->symbol (list->string (cons x xs)))))) 2.330 2.331 - (digit . ,(ometa-checker char-numeric? (apply ochar))) 2.332 + (name-initial . (seq (bind c (apply ochar)) 2.333 + (action (if (char-alphabetic? c) 2.334 + c 2.335 + (error 'expected 'char-alphabetic?))))) 2.336 2.337 - (spaces . (or (seq (many1 ,(ometa-checker char-whitespace? (apply ochar))) 2.338 + (name-subsequent . (seq (bind subsequent-chars (anything)) 2.339 + ;; 2.340 + (bind x (apply ochar)) 2.341 + (action (if (or (char-alphabetic? x) 2.342 + (char-numeric? x) 2.343 + (memv x subsequent-chars)) 2.344 + x 2.345 + (error 'expected 'name-subsequent))))) 2.346 + 2.347 + (digit . (seq (bind c (apply ochar)) 2.348 + (action (if (char-numeric? c) 2.349 + c 2.350 + (error 'expected 'char-numeric?))))) 2.351 + 2.352 + (spaces . (or (seq (many1 (seq (bind c (apply ochar)) 2.353 + (action (if (char-whitespace? c) 2.354 + c 2.355 + (error 'expected 'char-whitespace?))))) 2.356 (apply spaces)) 2.357 (seq (exactly #\-) (exactly #\-) 2.358 - (many ,(ometa-checker non-eol (anything) (x) 2.359 - (not (memv x '(#\return #\newline))))) 2.360 - (or (exactly #\return) (exactly #\newline)) 2.361 + (many (seq (bind x (anything)) 2.362 + (action (if (memv x '(#\return #\newline)) 2.363 + (error 'expected 'non-eol) 2.364 + x)))) 2.365 (apply spaces)) 2.366 - (action ,(ometa-lambda () #t)))) 2.367 + (action #t))) 2.368 2.369 (host-language-expression . (apply scheme-term)) 2.370 2.371 @@ -604,7 +605,7 @@ 2.372 (seq (apply token "(") 2.373 (bind xs (apply scheme-sequence)) 2.374 (apply token ")") 2.375 - (action ,(ometa-lambda (xs) xs))))) 2.376 + (action xs)))) 2.377 2.378 (scheme-quoted . (seq (bind quo (anything)) 2.379 (bind sym (anything)) 2.380 @@ -612,25 +613,25 @@ 2.381 (apply spaces) 2.382 (sequence quo) 2.383 (bind x (apply scheme-term)) 2.384 - (action ,(ometa-lambda (sym x) `(,sym ,x))))) 2.385 + (action `(,sym ,x)))) 2.386 2.387 (scheme-atom . (or (apply okeyword "#t" #t) 2.388 (apply okeyword "#f" #f) 2.389 (apply onumber) 2.390 (apply ostring #\") 2.391 (seq (apply token "#\\") (apply ochar)) 2.392 - (apply name) 2.393 + (apply generic-name '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\' #\< #\>)) 2.394 (seq (bind s (apply ostring #\|)) 2.395 - (action ,(ometa-lambda (s) (string->symbol s)))))) 2.396 + (action (string->symbol s))))) 2.397 2.398 (scheme-sequence . (or (seq (bind a (apply scheme-term)) 2.399 (apply token ".") 2.400 (bind d (apply scheme-term)) 2.401 - (action ,(ometa-lambda (a d) (cons a d)))) 2.402 + (action (cons a d))) 2.403 (seq (bind a (apply scheme-term)) 2.404 (bind d (apply scheme-sequence)) 2.405 - (action ,(ometa-lambda (a d) (cons a d)))) 2.406 - (action ,(ometa-lambda () '())))) 2.407 + (action (cons a d))) 2.408 + (action '()))) 2.409 ))) 2.410 2.411 (define (serialize-ometa-ast ast) 2.412 @@ -656,7 +657,7 @@ 2.413 (get-output-string s))) 2.414 (define (serialize-exp exp) 2.415 (case (car exp) 2.416 - ((apply) (xii "<" " " object->external-representation (cdr exp) ">")) 2.417 + ((apply) (xii "<(" " " object->external-representation (cdr exp) ")>")) 2.418 ((or) (xii "(" " | " serialize-exp (cdr exp) ")")) 2.419 ((exactly) (let ((ev (cadr exp))) 2.420 (cond 2.421 @@ -671,17 +672,18 @@ 2.422 (q #\' s) 2.423 s)))) 2.424 (else (error "Invalid literal in serialize-exp exactly" ev))))) 2.425 - ((sequence) (list "SEQ===" (cadr exp))) 2.426 + ((sequence) (list "<{"(object->external-representation (cadr exp))"}>")) 2.427 ((nest) (list "{"(serialize-exp (cadr exp))"}")) 2.428 ((not) (list "~"(serialize-exp (cadr exp)))) 2.429 ((follow) (list "&"(serialize-exp (cadr exp)))) 2.430 ((many) (list "("(serialize-exp (cadr exp))")*")) 2.431 ((many1) (list "("(serialize-exp (cadr exp))")+")) 2.432 - ((bind) (list (serialize-exp (caddr exp))":"(cadr exp))) 2.433 + ((bind) (if (equal? (caddr exp) '(anything)) 2.434 + (list ":"(cadr exp)) 2.435 + (list (serialize-exp (caddr exp))":"(cadr exp)))) 2.436 ((seq) (xi " " serialize-exp (cdr exp))) 2.437 - ((anything) "ANYTHING") 2.438 - ((check) (list "CHECK==="(serialize-exp (cadr exp))"::"(caddr exp))) 2.439 - ((action) (list "=>"(cadr exp))) 2.440 + ((anything) "_") 2.441 + ((action) (list "=>"(object->external-representation (cadr exp)))) 2.442 (else (error "Bad AST in serialize" exp)))) 2.443 (define (serialize-production production) 2.444 (list (car production)" ::=\n"