Changeset 27283 in project
- Timestamp:
- 08/22/12 03:02:19 (9 years ago)
- Location:
- release/4/9ML-toolkit/trunk
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/9ML-toolkit/trunk/NineML.grm
r25756 r27283 44 44 (left: LG LESS LEQ GREATER GEQ EQEQ EQUAL) 45 45 (left: PLUS MINUS STAR SLASH) 46 (right: TYPE VALUE ARROW MODULE FUNCTOR)46 (right: TYPE VALUE ARROW DARROW MODULE FUNCTOR) 47 47 (right: LPAREN SEMICOLON COLON QUOTE)) 48 48 … … 74 74 (valexpr GREATER valexpr) : (binop ">" $1 $3 ) 75 75 (valexpr GEQ valexpr) : (binop ">=" $1 $3 ) 76 (FUNCTION IDENT ARROW valexpr) : (Function $2 $4)76 (FUNCTION IDENT DARROW valexpr) : (Function $2 $4) 77 77 (LET IDENT valbind IN valexpr) : (Let0 $2 $3 $5) 78 78 (RETURN valexpr) : $2 -
release/4/9ML-toolkit/trunk/NineML.l
r25756 r27283 119 119 ";" (tok yyline SEMICOLON) 120 120 "->" (tok yyline ARROW) 121 "=>" (tok yyline DARROW) 121 122 "=" (tok yyline EQUAL) 122 123 "," (tok yyline COMMA) -
release/4/9ML-toolkit/trunk/eval.scm
r27270 r27283 83 83 (let recur ((p p) (ax '())) 84 84 (case (car p) 85 ((path) (recur (cadr p) ax)) 85 86 ((Pident) 86 (let ((id ( cadr p)))87 (let ((id (sxml:text (cdr p)))) 87 88 (let ((ax1 (cons id ax))) 88 (string- concatenate (intersperse (reverse ax1) "."))89 (string->symbol (string-concatenate (intersperse ax1 "."))) 89 90 ))) 90 91 ((Pdot) 91 92 (let ((name (sxml:attr p 'name))) 92 (recur (sxml:kid p) (cons nameax))))93 (recur (sxml:kid p) (cons (sxml:text name) ax)))) 93 94 (else (error 'sxml-path->symbol "invalid path" p)) 94 95 ))) 95 96 96 97 98 99 100 97 101 (define (sxml-term->sexpr term) 102 (print "term = " term) 98 103 (let ((tree 99 104 (sxml:pre-post-order* 100 105 term 101 106 `( 102 (Const . ,(lambda (tag elems) (car elems))) 103 (Longid . ,(lambda (tag elems) (sxml-path->symbol (car elems)))) 104 (Function *macro* . ,(lambda (tag elems) 105 (let ((formal (string->symbol (sxml:attr term 'formal)))) 106 `(lambda (,formal) ,elems)))) 107 (Apply *macro* . ,(lambda (tag elems) elems)) 108 (Let0 *macro* . ,(lambda (tag elems) 109 (let ((name (sxml:attr term 'name)) 110 (value (sxml:kidn-cadr 'value term)) 111 (body (sxml:kidn-cadr 'body term))) 112 `(let ((,name ,value)) 113 ,body)))) 107 (Const 108 ( 109 (label *preorder* . ,(lambda (tag elems) (string->symbol (sxml:text elems)))) 110 111 (string *preorder* . ,(lambda (tag elems) (sxml:text elems))) 112 113 (real *preorder* . ,(lambda (tag elems) (string->number (sxml:text elems)))) 114 115 (nat *preorder* . ,(lambda (tag elems) (string->number (sxml:text elems)))) 116 117 (bool *preorder* . ,(lambda (tag elems) (if (string=? (sxml:text elems) "true") #t #f))) 118 119 (null *preorder* . ,(lambda (tag elems) '())) 120 121 (*text* . ,(lambda (trigger str) str)) 122 123 (*default* . ,(lambda (tag elems) (cons tag elems))) 124 ) 125 126 . ,(lambda (tag elems) (car elems))) 127 128 (Longid *preorder* . ,(lambda (tag elems) (sxml-path->symbol (car elems)))) 129 (Function *preorder* . ,(lambda (tag elems) 130 (let ((formal (string->symbol (sxml:attr (cons tag elems) 'formal))) 131 (body (sxml:kid elems))) 132 (print "Function body = " body) 133 (print "Function formal = " formal) 134 `(lambda (,formal) ,(sxml-term->sexpr body))))) 135 (Let0 *preorder* . ,(lambda (tag elems) 136 (let ((name (string->symbol (sxml:attr (cons tag elems) 'name))) 137 (value (sxml:kidn-cadr 'value (cons tag elems))) 138 (body (sxml:kidn-cadr 'body (cons tag elems)))) 139 `(let ((,name ,(sxml-term->sexpr value))) 140 ,(sxml-term->sexpr body))))) 141 (Apply *macro* . ,(lambda (tag elems) 142 (let ((left (sxml:kidn-cadr 'left (cons tag elems))) 143 (right (sxml:kidn-cadr 'right (cons tag elems)))) 144 `(,left ,right)))) 145 (*text* . ,(lambda (trigger str) str)) 146 (*default* . ,(lambda (tag elems) (cons tag elems))) 114 147 )))) 115 148 tree)) … … 119 152 (let recur ((env env) (ax '())) 120 153 (if (null? env) 121 `(let ,ax,fin)154 `(let (,ax) ,fin) 122 155 (let ((en (car env))) 156 (print "en = " en) 157 (print "ax = " ax) 123 158 (let ((name (string->symbol (sxml:attr en 'name))) 124 159 (value (sxml-value->sexpr (sxml:kid en)))) 160 (print "value = " value) 125 161 (let ((en (list name value))) 126 (recur (cdr env) ( cons enax))162 (recur (cdr env) (if value (cons en ax) ax)) 127 163 ))) 128 164 ))) … … 130 166 131 167 (define (sxml-value->sexpr tree) 168 (print "tree = " tree) 132 169 (let* ((tree 133 170 (sxml:pre-post-order* 134 171 tree 135 172 `( 136 (Closure *macro* . 173 (Tuple *macro* . 174 ,(lambda (tag elems) 175 (let ((node (cons tag elems))) 176 (print "Tuple elems = " elems) 177 (let ((left (sxml:kidn-cadr 'left node)) 178 (right (sxml:kidn-cdr 'right node))) 179 (print "left = " left) 180 (print "right = " right) 181 (cons left right))) 182 )) 183 184 (Const ( 185 (label . ,(lambda (tag elems) (string->symbol (car elems)))) 186 187 (string . ,(lambda (tag elems) (car elems))) 188 189 (real . ,(lambda (tag elems) (string->number (car elems)))) 190 191 (nat . ,(lambda (tag elems) (string->number (car elems)))) 192 193 (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f))) 194 195 (null . ,(lambda (tag elems) '())) 196 197 (*text* . ,(lambda (trigger str) str)) 198 199 (*default* . ,(lambda (tag elems) (cons tag elems))) 200 201 ) . ,(lambda (tag elems) 202 (print "Const elems = " elems) 203 (car elems))) 204 205 (Closure . 137 206 ,(lambda (tag elems) 138 207 (let ((node (cons tag elems))) … … 140 209 (env (sxml:kidn-cdr 'env node))) 141 210 (let ((term (sxml-term->sexpr body))) 142 (sxml-eval-env->sexpr env term) 211 (list (sxml-eval-env->sexpr env term)) 212 ;; (list term) 143 213 ))) 144 214 )) 145 146 (Tuple *macro* . 147 ,(lambda (tag elems) 148 (let ((node (cons tag elems))) 149 (let ((left (sxml:kidn-cadr 'left node)) 150 (right (sxml:kidn-cdr 'right node))) 151 (cons left right))) 152 )) 153 154 (Const . ,(lambda (tag elems) (car elems))) 155 156 (label . ,(lambda (tag elems) (string->symbol (car elems)))) 157 158 (string . ,(lambda (tag elems) (car elems))) 159 160 (real . ,(lambda (tag elems) (car elems))) 161 162 (nat . ,(lambda (tag elems) (car elems))) 163 164 (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f))) 165 166 (null . ,(lambda (tag elems) '())) 167 215 216 168 217 (*text* . ,(lambda (trigger str) str)) 169 218 170 219 (*default* . ,(lambda (tag elems) (cons tag elems))) 220 171 221 ))) 172 222 … … 180 230 181 231 (*text* . ,(lambda (trigger str) str)) 182 232 183 233 (*default* . ,(lambda (tag elems) (cons tag elems))) 184 234 ))) … … 186 236 (tree 187 237 (let flatten ((tree tree)) 188 (cond ((atom? tree) tree) 189 (else (cons (flatten (car tree)) (flatten (cadr tree)))))))) 238 (cond ((or (atom? tree) (null? tree) (null? (cdr tree))) tree) 239 (else (cons (flatten (car tree)) 240 (flatten (cadr tree)))))))) 190 241 tree)) 191 242 -
release/4/9ML-toolkit/trunk/parse.scm
r25988 r27283 144 144 (cond [(not arg) (error loc-str msg)] 145 145 [(lexical-token? arg) 146 (error (conc "line " (source-location-line (lexical-token-source arg)) ": " msg) loc-str 146 (error (conc "line " (let ((src (lexical-token-source arg))) 147 (if (source-location? src) 148 (source-location-line (lexical-token-source arg)) 149 src)) ": " msg) 150 loc-str 147 151 (conc (lexical-token-category arg) 148 152 (if (lexical-token-value arg) (conc " " (lexical-token-value arg)) "")))]
Note: See TracChangeset
for help on using the changeset viewer.