├── README.md ├── expander ├── expander.rkt ├── matchers.rkt └── transformer.rkt └── runtime ├── commented-decompiler.rkt └── racket-eval.rkt /README.md: -------------------------------------------------------------------------------- 1 | meta 2 | ==== 3 | 4 | Exploration of the inner workings of Racket 5 | -------------------------------------------------------------------------------- /expander/expander.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;; THIS IS A WORK IN PROGRESS 4 | 5 | ;;; 6 | ;;; Macro Expander for Racket 7 | ;;; 8 | 9 | ; Racket's normal expander is implemented in C. 10 | ; This is an attempt to implement expand in Racket. 11 | 12 | ; This version focuses on the expansion of kernel forms. 13 | ; Currently standard syntax objects are used. 14 | ; New marks can be applied with syntax-introducers. 15 | ; Renamings are trickier, so either I might implement syntax 16 | ; objects as structs. The downside of doing so is that 17 | ; it makes more difficult to call transformers imported 18 | ; from modules compiled with the real expander. 19 | 20 | ; Next up: 1) Introduce fresh identifiers in let-values and lambda 21 | ; 2) Introduce expansion contexts. 22 | ; 3) Support syntax-local- constructs 23 | ; 4) Implement syntax-objects 24 | ; 5) Implement namespaces (and module registry) 25 | 26 | ;;; 27 | ;;; TRACE 28 | ;;; 29 | 30 | (define trace displayln) 31 | ; (define trace void) 32 | 33 | ;;; 34 | ;;; IMPORTS 35 | ;;; 36 | 37 | (require (for-syntax syntax/parse) 38 | (for-meta 2 racket/base) 39 | syntax/modresolve 40 | syntax/strip-context ; for strip-context 41 | syntax/stx 42 | "matchers.rkt") 43 | 44 | ; kernel-form-identifier-list is only used to catch unimplemented core syntax 45 | (require (only-in syntax/kerncase kernel-form-identifier-list)) 46 | 47 | ;;; 48 | ;;; BINDINGS 49 | ;;; 50 | 51 | ; An identifier is a name. Locations are cells in which a value is stored. 52 | ; An identifier that names a location is called a variable. 53 | ; An identifier that names syntax is called a syntactic keyword. 54 | ; An identifier is bound to the location. 55 | 56 | ; To find the location to which an identifier is bound is a two step process. 57 | ; First the label of identifier is determined, then the label is looked up 58 | ; in the environment. 59 | 60 | ; For identifiers represented as real syntax objects, the label is 61 | ; returned by identifier-binding-symbol. 62 | (define (id-label x) (identifier-binding-symbol x)) 63 | 64 | ; The same identifier can be bound in more than one phase. 65 | ; So either we need separate environments for each phase, 66 | ; or we need to associate a phase with each binding. 67 | ; Here we choose one environment and record the phase 68 | ; in which the label is associated to the label. 69 | 70 | ; The environment maps labels to bindings. 71 | (struct environment (associations) #:transparent) 72 | ; associations are lists of elements of the form (list p id l b) 73 | ; where p is a phase (integer or #f), 74 | ; id is an identifier (needed for reification when using real eval) 75 | ; l is a label, 76 | ; b is a binding: lexical, macro 77 | 78 | (struct binding (value) #:mutable #:transparent) 79 | (struct lexical binding () #:mutable #:transparent) 80 | (struct macro binding () #:mutable #:transparent) 81 | ; Syntax bindings are called "macro" here, since the 82 | ; name syntax is used to create syntax-objects. 83 | 84 | (define (local-eval x r [ns (current-namespace)]) 85 | (eval (reify-environment x r) ns)) 86 | 87 | (define (reify-environment x r) 88 | (define (reify as x) 89 | (match as 90 | ['() x] 91 | [(cons (list p id l (lexical v)) as) 92 | (cond [(= p 0) (reify as #`(let ([#,id #,v]) #,x))] 93 | [else (error)])] ; possible? 94 | [(cons (list p id l (macro v)) as) 95 | (cond [(= p 0) (reify as #`(let-syntax ([#,id #,v]) #,x))] 96 | [else (error)])] 97 | [else (error)])) 98 | (match-define (environment as) r) 99 | (reify as x)) 100 | 101 | 102 | (define empty-environment (environment '())) 103 | 104 | ; extend the environment with a binding b with label l, 105 | ; for id in phase p 106 | (define (extend r p id l b) 107 | (unless (binding? b) (error (list id b))) 108 | (match-define (environment as) r) 109 | (environment (cons (list p id l b) as))) 110 | 111 | (define (extend* env p ids ls bs) 112 | (unless (list? bs) (error)) 113 | (for/fold ([env env]) ([id (in-list ids)] [l (in-list ls)] [b (in-list bs)]) 114 | (extend env p id l b))) 115 | 116 | (define (extend** env p idss lss bss) 117 | (unless (andmap list? bss) (error bss)) 118 | (unless (andmap list? lss) (error lss)) 119 | (for/fold ([env env]) ([ids (in-list idss)] [ls (in-list lss)] [bs (in-list bss)]) 120 | (extend* env p ids ls bs))) 121 | 122 | (define (genlex) 123 | (lexical #f)) 124 | 125 | (define (genlex* is) 126 | (for/list ([i (in-list is)]) 127 | (genlex))) 128 | 129 | (define (genlex** iss) 130 | (for/list ([is (in-list iss)]) 131 | (genlex* is))) 132 | 133 | (define (genmac [v #f]) 134 | (macro v)) 135 | 136 | (define (genmac* is [vs #f]) 137 | (if vs 138 | (for/list ([i (in-list is)] [v (in-list vs)]) 139 | (genmac v)) 140 | (for/list ([i (in-list is)]) 141 | (genmac)))) 142 | 143 | (define (genmac** iss [vss #f]) 144 | (if vss 145 | (for/list ([is (in-list iss)] [vs (in-list vss)]) 146 | (genmac* is vs)) 147 | (for/list ([is (in-list iss)]) 148 | (genmac* is)))) 149 | 150 | (define (genlab) 151 | (gensym 'l)) 152 | 153 | (define (genlab* is) 154 | (for/list ([i (in-list is)]) 155 | (genlab))) 156 | 157 | (define (genlab** iss) 158 | (for/list ([is (in-list iss)]) 159 | (genlab* is))) 160 | 161 | 162 | 163 | ; find a binding associated with id in phase p, 164 | ; return #f id is unbound in phase p 165 | (define (lookup env phase id) 166 | (match-define (environment as) env) 167 | (for/first ([a (in-list as)] 168 | #:when (let() 169 | (match-define (list p i l b) a) 170 | (and (= p phase) 171 | (free-identifier=? i id)))) 172 | (match-define (list p i l b) a) 173 | b)) 174 | 175 | ; bindings can be top-level, module-level or lexical 176 | (define (has-nontop-binding? id p) 177 | (identifier-binding id p)) 178 | 179 | ; Note: has-nontop-binding? also works, when id is lexically bound to syntax 180 | ; > (let-syntax ([m (lambda (stx) #'42)]) 181 | ; (identifier-binding #'m)) 182 | ; 'lexical 183 | 184 | (require "transformer.rkt") 185 | 186 | (define (bound? r p id) 187 | (or (lookup r p id) ; lexical 188 | (if (= p 0) 189 | (or (identifier-binding id) ; module 190 | (namespace-variable-value (syntax->datum id) #f (λ () #f))) ; top-level 191 | (eval-for-meta 192 | p #`(or (identifier-binding #'#,id) 193 | (namespace-variable-value (syntax->datum #'#,id) #f (λ () #f))))))) 194 | 195 | (define (unbound? r p id) 196 | (not (bound? r p id))) 197 | 198 | 199 | ; top-identifier-type : identifier phase -> (or #f 'syntax (list value)) 200 | ; given an identifier id determine whether x is value or syntax bound in phase p 201 | ; assumption: (identifier-binding id) returns #f 202 | ; return #f if id is unbound in phase p in namespace 203 | ; 'syntax if id is bound to syntax (most often the value is a transformer) 204 | ; (list v) if id is bound to the value v 205 | (define (top-identifier-type id p) 206 | (unless (= p 0) (error)) 207 | (with-handlers ([exn:fail:syntax? (λ (e) 'syntax)] 208 | [exn:fail:contract:variable? (λ (e) #f)]) 209 | (define sym (syntax->datum id)) ; TODO: substitutions ? 210 | (list (namespace-variable-value sym #t)))) 211 | 212 | (define (lexical-identifier-type id p env) 213 | (lookup env p id)) 214 | 215 | ; module-identifier-type : identifier phase binding-info -> (or 'kernel 'syntax (list value)) 216 | ; the binding-info in b is the output of (identifier-binding id) 217 | (define (module-identifier-type id p b) 218 | (displayln (list 'module-identifier-type id p b)) 219 | (match-define (list src-mod src-id _ _ src-phase _ _) b) 220 | (define rmpi (resolve-module-path-index src-mod #f)) 221 | (match rmpi 222 | ['#%kernel (list src-id 'kernel)] 223 | [_ (with-namespace (module->namespace rmpi) 224 | (with-handlers ([exn:fail:syntax? (λ (e) 'syntax)] 225 | [exn:fail:contract:variable? (λ (e) (error "internal error"))]) 226 | (if (= p 0) 227 | (list (namespace-variable-value src-id #t)) 228 | (eval-for-meta p #`(namespace-variable-value #,src-id #t)))))])) 229 | 230 | ; identifier-top-binding : identifier phase -> (or/c #f 'syntax 'value) 231 | ; return #f if id is unbound in phase in namespace 232 | ; 'syntax if id is bound to syntax (most often the value is a transformer) 233 | ; (list v) if id is bound to the value v 234 | (define (identifier-top-binding id p) 235 | (unless (= p 0) (error)) 236 | (define b (identifier-binding id)) 237 | (match b 238 | [#f #f] 239 | ['lexical (error 'identifier-top-binding "expected nonlexical identifier: ~a" id)] 240 | [else 241 | (with-namespace (module->namespace (first b)) 242 | (with-handlers ([exn:fail:syntax? (λ (e) 'syntax)] 243 | [exn:fail:contract:variable? (λ (e) #f)]) 244 | (define sym (syntax->datum id)) ; TODO: substitutions ? 245 | (list (namespace-variable-value sym #t))))])) 246 | 247 | ; syntax-value : identifier phase -> value 248 | ; given an identifier id bound to syntax in phase p, 249 | ; return the value associated with p (most often a transformer) 250 | #;(define (syntax-value id p) 251 | ; for an identifier id bound to syntax in phase p, 252 | ; get the value (most commonly a syntax transformer) 253 | (unless (= p 0) (error)) ; not implemented for p>0 yet 254 | (let/ec return 255 | (eval `(let-syntax ([m (λ(_) (,return (syntax-local-value #',id)))]) (m)) 256 | (variable-reference->namespace (#%variable-reference))))) 257 | 258 | 259 | ; kernel-form-identifier? : identifier -> boolean 260 | ; 261 | (define kernel-form-identifier? 262 | (let () 263 | (define kernel-form-identifiers (kernel-form-identifier-list)) 264 | (λ (xid) 265 | (memf (λ(kid) (free-identifier=? xid kid)) 266 | kernel-form-identifiers)))) 267 | 268 | ;;; 269 | ;;; NOTES 270 | ;;; 271 | 272 | 273 | ; parameter: syntax-local-phase-level 274 | ; During the dynamic extent of a syntax transformer application by the expander, 275 | ; the result is the phase level of the form being expanded. Otherwise, the result is 0. 276 | 277 | ; parameter: syntax-local-context 278 | ; (or/c 'expression 'top-level 'module 'module-begin list?) 279 | ; Returns an indication of the context for expansion that triggered a syntax transformer call. 280 | 281 | ; parameter: syntax-local-name 282 | ; Returns an inferred name for the expression position being transformed, 283 | ; or #f if no such name is available. 284 | 285 | ;;; 286 | ;;; 287 | ;;; 288 | 289 | ; (syntax-track-origin new-stx orig-stx id-stx) 290 | ; Adds properties to new-stx in the same way that macro expansion 291 | ; adds properties to a transformer result. 292 | 293 | ; syntax: (with-namespace ns body ...+) 294 | ; parameterize current-namespace to ns, and evalute bodies 295 | (define-syntax (with-namespace stx) 296 | (syntax-parse stx 297 | [(_ ns body ...+) 298 | #'(parameterize ([current-namespace ns]) 299 | body ...)])) 300 | 301 | ; syntax: namespace-here 302 | ; evaluates to the namespace of the top-level or module-top-level 303 | (define-syntax (namespace-here stx) 304 | (with-syntax ([anchor (syntax-local-lift-expression #'(#%variable-reference))]) 305 | #'(variable-reference->namespace anchor))) 306 | 307 | 308 | (define (apply-unless p f v) 309 | (if (p v) v (f v))) 310 | 311 | (define (apply-when p f v) 312 | (if (p v) (f v) v)) 313 | 314 | (define (sym-or-id? x) 315 | (or (symbol? x) (and (syntax? x) (symbol? (syntax-e x))))) 316 | 317 | ;;; 318 | ;;; EXPANSION 319 | ;;; 320 | 321 | ; Expansion begins with a top-level-form. 322 | ; Expansion always takes place in the context of a namespace. 323 | ; A namespace associates symbols with identifiers. 324 | ; A namespace is a *top-level* concept and must not be confused 325 | ; with an environment (which tracks local bindings). 326 | ; Example: To (expand '(+ 1 2)) the '+ needs to be associated 327 | ; with the addition primitive. In a base namespace we get 328 | ; > (~id (namespace-symbol->identifier '+)) 329 | ; '(+ (#%kernel + # + 0 0 0)) 330 | ; The source module is #%kernel in which it was called + 331 | ; and it was imported to the current namespace from "main.rkt" 332 | ; where the name also was +. All imports and exports were in phase 0. 333 | 334 | ; Unless a compiled datum (the original expression were expanded 335 | ; before ut was compiled) or a or a module form (whose meaning 336 | ; is independent on the bindings of the current namespace) 337 | ; the entire top-level-form is enriched with the lexical information 338 | ; of the current-namespace. 339 | 340 | (define (meta-expand top-level-form [ns (current-namespace)]) 341 | (define phase 0) 342 | (with-namespace ns 343 | (continue (enrichen-top-level-form top-level-form) 344 | phase 345 | empty-environment))) 346 | 347 | 348 | (define (enrichen-top-level-form top-level-form) 349 | ; see docs for eval 350 | (define introduce namespace-syntax-introduce) 351 | (match top-level-form 352 | [(? syntax? s) 353 | (match (syntax-e s) 354 | [(? compiled-expression? c) c] 355 | [(cons (? sym-or-id? mod?) more) 356 | (define mod (introduce mod?)) 357 | (if (bound-identifier=? mod #'module) 358 | (datum->syntax #f (cons mod more)) 359 | (introduce s))] 360 | [_ (introduce s)])] 361 | [d (enrichen-top-level-form (datum->syntax #f d #f))])) 362 | 363 | (define (meta-expand-once top-level-form) 364 | ; Partially expands top-level-form and returns a syntax object for 365 | ; the partially-expanded expression. Due to limitations in the 366 | ; expansion mechanism, some context information may be lost. 367 | ; In particular, calling expand-once on the result may produce 368 | ; a result that is different from expansion via expand. 369 | 370 | ; Before top-level-form is expanded, its lexical context is enriched 371 | ; with namespace-syntax-introduce, as for eval. 372 | (meta-expand-syntax-once 373 | (enrichen-top-level-form top-level-form))) 374 | 375 | (define (meta-expand-syntax-once top-level-form) 376 | ; Like (expand-once stx), except that the argument must be a syntax object, 377 | ; and its lexical context is not enriched before expansion. 378 | (error)) 379 | 380 | (define (expand-to-top-form top-level-form) 381 | ; Partially expands top-level-form to reveal the outermost syntactic form. 382 | ; This partial expansion is mainly useful for detecting top-level uses of begin. 383 | ; Unlike the result of expand-once, expanding the result of expand-to-top-form 384 | ; with expand produces the same result as using expand on the original syntax. 385 | ; Before stx-or-sexpr is expanded, its lexical context is enriched with 386 | ; namespace-syntax-introduce, as for eval. 387 | (meta-expand-syntax-to-top-form 388 | (enrichen-top-level-form top-level-form))) 389 | 390 | (define (meta-expand-syntax-to-top-form top-level-form) 391 | ; Like (expand-to-top-form stx), except that the argument must be a syntax object, 392 | ; and its lexical context is not enriched before expansion. 393 | (error) 394 | '(syntax-parse top-level-form 395 | (match (syntax-e top-level-form) 396 | [(list '#%expression expr) '...] 397 | [(list '#%module '...) 398 | ...]))) 399 | 400 | (define (syntax: x datum [srcloc #f] [prop #f]) 401 | (cond 402 | [(and srcloc prop) (datum->syntax x datum srcloc prop)] 403 | [srcloc (datum->syntax x datum srcloc x)] 404 | [else (datum->syntax x datum x x)])) 405 | 406 | ; continue : syntax phase environment -> syntax 407 | ; expand x in phase p 408 | (define (continue x p r) 409 | (trace (list 'continue 'x x)) 410 | (cond 411 | [(identifier? x) (meta-expand-identifier x p r)] 412 | [(stx-pair? x) (define a (stx-car x)) 413 | (cond [(identifier? a) 414 | (define b (or (identifier-binding a p) (lookup r p a))) 415 | ;(displayln (list 'continue 'b (~b b))) 416 | ; determine binding type 417 | (define t (match b 418 | [#f (top-identifier-type a p)] ; unbound or top 419 | ['lexical (lexical-identifier-type r p a)] ; local 420 | [(macro _) b] ; bound by meta expansion 421 | [_ (module-identifier-type a p b)])) 422 | (match t 423 | ; these handle "real" binding info 424 | [(list _ 'kernel) (meta-expand-kernel-application x p r a #f b t)] 425 | ['syntax (meta-expand-macro-application x p r a #f b t)] 426 | [(list value) (meta-expand-introduce-#%app x p r)] 427 | ; these handle bindings introduced by meta expansion 428 | [(macro _) (meta-expand-macro-application x p r a #f b t)] 429 | [#f (error 'meta-expand "reference to undefined identifier: ~a ~a" a t)] 430 | [_ (displayln (list a b t)) 431 | (error 'continue "internal error")])] 432 | [else ; could be ((foo)) 433 | (meta-expand-introduce-#%app x p r)])] 434 | [else (meta-expand-introduce-#%datum x p r)])) 435 | 436 | (define (meta-expand-expression x p r) 437 | (continue x p r)) 438 | 439 | (define (meta-expand-bodies xs p r dc) 440 | ; TODO: Handle definitions 441 | ; TODO: Handle mix of definitions and expressions 442 | (for/list ([x (in-list xs)]) 443 | (meta-expand-expression x p r))) 444 | 445 | ; check-formals : syntax syntax -> (or #f (list identifier)) 446 | ; return list of identifiers in formals, 447 | ; return #f if x is not a formals 448 | (define (check-formals x fs) 449 | (match fs 450 | [(stx-list (? identifier? id) ...) id] 451 | [(? identifier? id) (list id)] 452 | [(stx-list-rest (? identifier? id) ... idn) (append id (list idn))] 453 | [_ (raise-syntax-error x "expected formals" x)])) 454 | 455 | 456 | (define (meta-expand-kernel-application x p r xid id? b t) 457 | (trace (list 'meta-expand-kernel-application x p r xid id? b t)) 458 | (match-define (list sym 'kernel) t) 459 | (match sym 460 | ; TODO : In a module context #%top raises an unbound error (not so in the top-level) 461 | ['#%top ; (#%top . id) => i 462 | (cond [id? (raise-syntax-error "#%top bad syntax")] 463 | [else (define id (stx-cdr x)) 464 | (cond #;[(and (identifier? id) (= p 0) (unbound? e 0 id)) 465 | (raise-syntax-error 466 | #f 467 | "undefined;\ncannot reference an identifier before its definition" id)] 468 | [(identifier? id) id] 469 | [else (error "bad syntax #%top" x)])])] 470 | ['#%datum ; (#%datum . d) => (quote d) unless d is a keyword 471 | (cond [id? (raise-syntax-error "meta: #%datum bad syntax")] 472 | [else (define d (stx-cdr x)) 473 | (cond [(keyword? d) (error "#%datum: keyword used as expression")] 474 | [else (define q (syntax: x 'quote)) 475 | (syntax: x (cons q (cons d '())))])])] 476 | ['#%app ; (#%app proc-expr arg ...) Applies a procedure. 477 | ; ; this is actually #%plain-app. #%kernel exports it as #%app 478 | ; ; TODO: special case: (#%plain-app) expands to '() 479 | (cond [id? (raise-syntax-error "#%app illegal use")] 480 | [else (define d (stx-cdr x)) 481 | (cond [(stx-list? d) (define args (stx->list d)) 482 | (define expanded-args (map (λ (a) (continue a p r)) args)) 483 | (syntax: x (cons xid expanded-args))] 484 | [else (error "application illegal use of .")])])] 485 | ['let-values ; (let-values ([(id ...) val-expr] ...) body ...+) 486 | (if id? (raise-syntax-error "let-values illegal use") 487 | (match x 488 | [(stx-list l-v (stx-list (stx-list (stx-list idss ...) ves) ...) bs ..1) 489 | (let* (; expand es in old environment 490 | [ves (stx-map (λ (x) (meta-expand-expression x p r)) ves)] 491 | ; extend environment (i.e. gived idss lexical bindings) 492 | [e* (extend** r p idss (genlab** idss) (genlex** idss))] 493 | ; make new definition context 494 | ; TODO: (define dc (meta-syntax-local-make-definition-context)) 495 | [dc 'internal-definition-context] 496 | [bs (meta-expand-bodies bs p e* dc)] 497 | ; assemble clauses 498 | [cs (for/list ([ids (in-list idss)] [ve (in-list ves)]) 499 | (list ids ve))]) 500 | ; assemble fully expanded let-values 501 | (syntax: x (list* l-v cs bs)))] 502 | [_ 503 | (error "let-values illegal use")]))] 504 | ['letrec-values ; (letrec-values ([(id ...) val-expr] ...) body ...+) 505 | (if id? (raise-syntax-error "letrec-values illegal use") 506 | (match x 507 | [(stx-list l-v (stx-list (stx-list (stx-list idss ...) ves) ...) bs ..1) 508 | (let* (; extend environment (i.e. gived idss lexical bindings) 509 | [e* (extend** r p idss 'value)] 510 | ; expand es in new environment 511 | [ves (stx-map (λ (x) (meta-expand-expression x p e*)) ves)] 512 | ; make new definition context 513 | ; TODO: (define dc (meta-syntax-local-make-definition-context)) 514 | [dc 'internal-definition-context] 515 | [bs (meta-expand-bodies bs p e* dc)] 516 | ; assemble clauses 517 | [cs (for/list ([ids (in-list idss)] [ve (in-list ves)]) 518 | (list ids ve))]) 519 | ; assemble fully expanded let-values 520 | (syntax: x (list* l-v cs bs)))] 521 | [_ 522 | (error "letrec-values illegal use")]))] 523 | ['define-values ; (define-values (id ...) expr) 524 | (if id? (raise-syntax-error "define-values illegal use") 525 | (match x 526 | [(stx-list d-v (stx-list ids ...) expr) 527 | (let* (; extend environment 528 | [e* (extend* r p ids (genlab* ids) (genlex* ids))] 529 | ; expand expr in new environment 530 | [v (meta-expand-expression expr p e*)]) 531 | ; assemble fully expanded define-values 532 | (syntax: x (list d-v ids v)))] 533 | [_ 534 | (displayln x) 535 | (error "define-values illegal use")]))] 536 | ['set! ; (set! id expr) 537 | (if id? (raise-syntax-error #f "bad syntax" xid) 538 | (match x 539 | [(stx-list s! id expr) 540 | (unless (identifier? id) (raise-syntax-error 'set! "not an identifier" id)) 541 | (let* ([expr (meta-expand-expression expr p r)]) 542 | (syntax: x (list s! id expr)))] 543 | [_ (raise-syntax-error 'set! "bad syntax" x)]))] 544 | ['if ; (if expr expr expr) 545 | (if id? (raise-syntax-error #f "bad syntax" xid) 546 | (match x 547 | [(stx-list i e0 e1 e2) 548 | (let* ([e0 (meta-expand-expression e0 p r)] 549 | [e1 (meta-expand-expression e1 p r)] 550 | [e2 (meta-expand-expression e2 p r)]) 551 | (syntax: x (list i e0 e1 e2)))] 552 | [_ (raise-syntax-error 'if "bad syntax" x)]))] 553 | ['begin ; (begin expr ..+) 554 | ; TODO: top-level begins are in separate definition contexts 555 | (if id? (raise-syntax-error #f "bad syntax" xid) 556 | (match x 557 | [(stx-list beg es ..1) 558 | (let* ([es (for/list ([e0 (in-list es)]) 559 | (meta-expand-expression e0 p r))]) 560 | (syntax: x (list* beg es)))] 561 | [_ (raise-syntax-error 'begin "bad syntax" x)]))] 562 | ['begin0 ; (begin0 expr expr ...) 563 | ; TODO: top-level begins are in separate definition contexts 564 | (if id? (raise-syntax-error #f "bad syntax" xid) 565 | (match x 566 | [(stx-list beg0 es ..1) 567 | (let* ([es (for/list ([e0 (in-list es)]) 568 | (meta-expand-expression e0 p r))]) 569 | (syntax: x (list* beg0 es)))] 570 | [_ (raise-syntax-error 'begin0 "bad syntax" x)]))] 571 | ['#%expression ; (#%expression expr) 572 | ; TODO: (meta-expand '(or 4 5)) wraps '5 in (#%expression _), expand doesn't. Why? 573 | ; Because: If a macro transformer returns (#%expression e) into a 574 | ; a context known to be an expression context, the #%expression needs to be discarded. 575 | ; (The point of #%expression is to force an expression context, where there is doubt.) 576 | (if id? (raise-syntax-error #f "bad syntax" xid) 577 | (match x 578 | [(stx-list ex e0) 579 | (displayln "--#%expression--") 580 | (let ([e0 (meta-expand-expression e0 p r)]) 581 | (match e0 582 | [(stx-cons (<#%expression>) _) (syntax: x e0)] ; don't repeat 583 | [_ (syntax: x (list ex e0))]))] ; common case 584 | [_ (raise-syntax-error '#%expression "bad syntax" x)]))] 585 | ['quote ; (quote datum) 586 | (if id? (raise-syntax-error #f "bad syntax" xid) 587 | (match x 588 | [(stx-list q d) 589 | ; remove all lexical context from datum 590 | (syntax: x (list q (strip-context d)))] 591 | [_ (raise-syntax-error 'quote "bad syntax" x)]))] 592 | ['quote-syntax ; (quote-syntax datum) 593 | (if id? (raise-syntax-error #f "bad syntax" xid) 594 | (match x 595 | [(stx-list sq d) 596 | ; keep lexical context from datum 597 | (syntax: x (list sq d))] 598 | [_ (raise-syntax-error 'syntax-quote "bad syntax" x)]))] 599 | ['with-continuation-mark ; (with-continuation-mark expr expr expr) 600 | (if id? (raise-syntax-error #f "bad syntax" xid) 601 | (match x 602 | [(stx-list wcm e0 e1 e2) 603 | (let* ([e0 (meta-expand-expression e0 p r)] 604 | [e1 (meta-expand-expression e1 p r)] 605 | [e2 (meta-expand-expression e2 p r)]) 606 | (syntax: x (list wcm e0 e1 e2)))] 607 | [_ (raise-syntax-error 'with-continuation-mark "bad syntax" x)]))] 608 | ['#%variable-reference 609 | (if id? (raise-syntax-error #f "bad syntax" xid) 610 | (match x 611 | [(stx-list vr) x] 612 | [(or (stx-list vr (? identifier? id)) 613 | (stx-list vr (stx-cons (<#%top>) (? identifier? id)))) 614 | x] 615 | [_ (raise-syntax-error '#%variable-reference "bad syntax" x)]))] 616 | ['lambda ; (#%plain-lambda formals body ...+) 617 | ; ; #%plain-lambda is exported as lambda by #%kernel 618 | (displayln "XXXXXXXXX") 619 | (if id? (raise-syntax-error #f "bad syntax" xid) 620 | (match x 621 | [(stx-list pl formals bs ..1) 622 | (define ids (check-formals x formals)) 623 | (let* (; extend environment (i.e. gived idss lexical bindings) 624 | [e* (extend* r p ids (genlab* ids) (genlex* ids))] 625 | ; expand body ... in new environment 626 | ; TODO: (define dc (meta-syntax-local-make-definition-context)) 627 | ; make new definition context 628 | [dc 'internal-definition-context] 629 | [bs (meta-expand-bodies bs p e* dc)]) 630 | (syntax: x (list* pl formals bs)))] 631 | [_ (raise-syntax-error '#%plain-lambda "bad syntax" x)]))] 632 | ['case-lambda ; (case-lambda [formals body ...+)] ... 633 | (if id? (raise-syntax-error #f "bad syntax" xid) 634 | (match x 635 | [(stx-list cl (stx-list formalss bss ..1) ...) 636 | (define idss (for/list ([formals (in-list formalss)]) 637 | (check-formals x formals))) 638 | (define cases 639 | (for/list ([ids (in-list idss)] [bs (in-list bss)]) 640 | (let* (; extend environment (i.e. gived ids lexical bindings) 641 | [e* (extend* r p ids 'value)] 642 | ; expand body ... in new environment 643 | ; TODO: (define dc (meta-syntax-local-make-definition-context)) 644 | ; make new definition context 645 | [dc 'internal-definition-context] 646 | [bs (meta-expand-bodies bs p e* dc)]) 647 | (list ids bs)))) 648 | (syntax: x (list* cl cases))] 649 | [_ (raise-syntax-error '#%plain-lambda "bad syntax" x)]))] 650 | ['letrec-syntaxes+values 651 | (if id? (raise-syntax-error #f "bad syntax" xid) 652 | (match x 653 | [(stx-list lsv 654 | (stx-list (stx-list (stx-list trans-idss ...) trans-exprs) ...) 655 | (stx-list (stx-list (stx-list val-idss ...) val-exprs) ...) 656 | bs ..1) 657 | (let* ; TODO: rename ids in trans-idss and val-idds per paper 658 | (; expand the transformer expressions in an empty environment 659 | ; Note: Racket specifies an empty environment 660 | [tes (for/list ([te (in-list trans-exprs)]) 661 | (meta-expand-expression te p empty-environment))] 662 | ; evaluate the (fully) expanded expressions 663 | [tes-vals (for/list ([te (in-list trans-exprs)]) 664 | (call-with-values (λ () (eval te)) list))] 665 | [*_* (displayln (list 'trans-exprs trans-exprs 666 | 'tes tes 667 | 'tes-vals tes-vals))] 668 | ; bind idss lexically and trans-ids to syntax 669 | [r* (extend** r p val-idss (genlab** val-idss) (genlex** val-idss))] 670 | [r* (extend** r* p trans-idss (genlab** trans-idss) (genmac** trans-idss tes-vals))] 671 | ; expand value expressions in an environment where val-idss and trans-idss are bound 672 | [val-exprs (for/list ([ve (in-list val-exprs)]) 673 | (meta-expand-expression ve p r*))] 674 | ; TODO: (define dc (meta-syntax-local-make-definition-context)) 675 | ; make new definition context 676 | [dc 'internal-definition-context] 677 | [bs (meta-expand-bodies bs p r* dc)]) 678 | ; the transformer clauses are discarded and the form reduces 679 | ; to "a combination of letrec-values or let-values" 680 | (match val-idss 681 | ['() (syntax: x (list* #'let-values '() bs))] 682 | [_ (syntax: x (list* #'letrec-values 683 | (map list val-idss val-exprs) 684 | bs))]))] 685 | [_ (raise-syntax-error 'letrec-syntaxes+values "bad syntax" x)]))] 686 | ['begin-for-syntax 687 | (if id? (raise-syntax-error #f "bad syntax" xid) 688 | (match x 689 | [(stx-list bfs forms ...) 690 | (syntax: x (list* bfs (for/list ([x forms]) 691 | (meta-expand-top-form x (+ p 1) r))))] 692 | [_ (raise-syntax-error 'begin-for-syntax "bad syntax" x)]))] 693 | [(? (λ (_) (kernel-form-identifier? xid))) 694 | (displayln x) 695 | (error)] ; implement it! 696 | ; XXX we now need to now if it is bound to syntax ... 697 | [(? (λ(_) id?)) x] ; reference to module-level id 698 | [else ; application of module-level id 699 | (meta-expand-introduce-#%app x p r)])) 700 | 701 | (define (meta-expand-top-form x p r) 702 | (continue x p r)) 703 | 704 | ; meta-expand-module-application : syntax phase env identifier boolean binding binding-type -> syntax 705 | ; xid is a module bound identifier (and not from #%kernel) 706 | ; id? = #t means x is an identifier (and x and xid are eq?) 707 | ; id? = #f means x has the form (xid . _) where xid is an identifier 708 | ; b = output from identifier-binding 709 | ; t = output from module-identifier-type 710 | ; or #f (in which case module-identifier-type is called here) 711 | (define (meta-expand-module-application x p r xid id? b t) 712 | (trace (list 'meta-expand-module-application x p r xid id? b t)) 713 | (match (or t (module-identifier-type xid p b)) 714 | ['syntax (meta-expand-macro-application x p r xid id? b t)] ; macro 715 | [(? (λ(_) id?)) xid] ; reference 716 | [_ (meta-expand-introduce-#%app x p r)])) ; application 717 | 718 | ; meta-expand-macro-application : syntax phase env identifier boolean -> syntax 719 | ; xid is an identifier bound to syntax 720 | ; id? = #t means x is an identifier (and x and xid are eq?) 721 | ; id? = #f means x has the form (xid . _) where xid is an identifier 722 | ; b = output from identifier-binding 723 | ; t - output from *-identifier-type 724 | (define (meta-expand-macro-application x p r xid id? b t) 725 | (trace (list 'meta-expand-macro-application x p r xid id? b t)) 726 | ; TODO: handle identifier-macros, set!-macros and rename-macros (more?) 727 | ; TODO: install parameters for syntax-transforming? , syntax-local- ... 728 | ; TODO: check that output from T is syntax 729 | ; TODO: merge syntax properties : see 12.7 in the reference 730 | ; TODO: use syntax-track-origin 731 | 732 | ; Since this is a meta-expander we have two types of macros to handle: 733 | ; i) introduced by meta-expansion 734 | ; ii) introduced by real expansion 735 | (define type (match b [(macro _) 'meta] [_ 'real])) 736 | ; In both cases we need to get the transformer T associated with the binding. 737 | (define T 738 | (let loop ([b b]) 739 | (match b 740 | [(macro (? procedure? transformer)) transformer] ; ad i) 741 | [(macro (? rename-transformer? rt)) 742 | (loop (lookup r p (rename-transformer-target rt)))] 743 | [_ (syntax-value xid p)]))) ; ad ii) 744 | 745 | (unless (procedure? T) 746 | (displayln (list 'T: T)) 747 | (error "bad use of syntax in:" x)) 748 | 749 | (define m (make-syntax-introducer)) ; get new mark m 750 | (define mx (m x)) ; apply it to input syntax 751 | (displayln (list 'here: T mx)) 752 | (define Tmx ; apply transformer 753 | (match type 754 | ['meta (T mx)] 755 | ['real (call-transformer T mx 'expression)])) 756 | (define out (m Tmx)) ; mark again 757 | (displayln (list 'macro: 'in xid 'out out)) 758 | (continue out p r)) ; apply mark before and after application of transformer 759 | 760 | 761 | 762 | (define (call-transformer T mx context) ; mx is already marked 763 | ; Conceptually just (call-transformer T mx) == (T mx) 764 | ; However to support calling real Racket transformer, 765 | ; some of them use syntax-local- constructs, that throws 766 | ; exn:fail if called while not transforming (using the real expander). 767 | ; Here we try if (T mx) works, and if it does fine. 768 | ; If an exception is thrown, we attempt to emulate transforming 769 | ; by calling fake-transform. 770 | (with-handlers ([syntax-local-exn? 771 | (λ (_) (fake-transform T mx context))]) 772 | (T mx))) 773 | 774 | ; syntax-local-exn? : exception -> boolean 775 | ; was the exception thrown by a syntax-local- construct? 776 | (define (syntax-local-exn? e) 777 | (and (exn:fail? e) 778 | (regexp-match #rx"^syntax-local-.*" (exn-message e)))) 779 | 780 | ; fake-transform : transformer syntax context 781 | ; call the transformer T on x in the given local context 782 | (define (fake-transform T x context) 783 | (trace (list 'fake-transform T x context)) 784 | ; this call the transformer T in an expression context 785 | (match context 786 | ['expression (define out (let/ec return 787 | (eval `(let-syntax ([m (λ(_) (,return (,T #',x)))]) (m))))) 788 | (displayln out) 789 | out] 790 | [_ (error)])) ; todo 791 | 792 | (define (meta-expand-identifier x p r) 793 | (trace (list 'meta-expand-identifier x p r)) 794 | (define b (identifier-binding x p)) 795 | (match b 796 | [#f ; reference to top-level or unbound 797 | (meta-expand-introduce-#%top x p r)] 798 | ['lexical 799 | (meta-expand-nontop-binding x p r b x #t)] 800 | [_ ; module 801 | (meta-expand-module-application x p r x #t b #f)])) 802 | 803 | 804 | ; meta-expand-nontop-binding : syntax phase env binding boolean -> syntax 805 | ; id? = #t means x is an identifier, #f means (cons xid . _) 806 | ; binding info in b stems from (identifier-binding x) or (identifier-binding xid) 807 | ; if x is an identifier, pass xid and x should be eq? 808 | (define (meta-expand-nontop-binding x p r b xid id?) 809 | ; (trace (list 'meta-expand-nontop-binding x p e (~b b) xid id?)) 810 | (trace (list 'meta-expand-nontop-binding x)) 811 | (match b 812 | ['syntax ; xid is bound to a syntax 813 | (meta-expand-macro-application x p r xid id?)] 814 | ['lexical ; a lexical binding (e.g. bound by let or define) 815 | (if id? 816 | xid ; variable reference 817 | (meta-expand-introduce-#%app x p))] 818 | ; module bound 819 | [(list nom-mpi nom-sym src-mpi src-sym src-p in-p nom-ex-p) 820 | (cond 821 | ; (#%top . id) => id 822 | [(bound-identifier=? xid #'#%top) 823 | (cond [id? (raise-syntax-error "#%top bad syntax")] 824 | [else (define id (stx-cdr x)) 825 | (cond [(identifier? id) id] 826 | [else (error "bad syntax #%top" x)])])] 827 | ; (#%datum . d) => (quote d) unless d is a keyword 828 | [(bound-identifier=? xid #'#%datum) 829 | (cond [id? (raise-syntax-error "#%datum bad syntax")] 830 | [else (define d (stx-cdr x)) 831 | (cond [(keyword? d) (error "#%datum: keyword used as expression")] 832 | [else (define q (syntax: x 'quote)) 833 | (syntax: x (cons q (cons d '())))])])] 834 | ; (#%app proc-expr arg ...) Applies a procedure. 835 | [(bound-identifier=? xid #'#%app) 836 | (cond [id? (raise-syntax-error "#%app illegal use")] 837 | [else (define d (stx-cdr x)) 838 | (cond [(stx-list? d) (define args (stx->list d)) 839 | (define expanded-args (map (λ (a) (continue a p r)) args)) 840 | (syntax: x (cons xid expanded-args))] 841 | [else (error "application illegal use of .")])])] 842 | ; 843 | #;(with-namespace (module->namespace mpi) 844 | (with-handlers ([exn:fail:syntax? (λ (e) 'syntax)]) 845 | (namespace-variable-value 'let))) 846 | ; raises an exception for #%kernel 847 | #;(with-namespace (module->namespace (first (identifier-binding #'map))) 848 | (with-handlers ([exn:fail:syntax? (λ (e) 'syntax)] 849 | [exn:fail:contract:variable? (λ (e) 'unbound)]) 850 | (namespace-variable-value 'map #t))) 851 | 852 | ; XXX we now need to now if it is bound to syntax ... 853 | [id? x] ; reference to module-level id 854 | [else ; application of module-level id 855 | (meta-expand-introduce-#%app x p r)])] 856 | [_ (error)])) 857 | 858 | 859 | (define (meta-expand-introduce-#%top x p r) 860 | (trace (list 'meta-expand-introduce-#%top x p r)) 861 | ; note: top is usually bound to the #%top from #%kernel 862 | ; create new #%top symbol with lexical info from x 863 | (define top (syntax: x '#%top)) 864 | ; if #%app is bound, expand (#%app . x) 865 | (if (unbound? r p top) 866 | (raise (exn:fail:syntax "no #%top bound" (current-continuation-marks) (list x))) 867 | (continue (syntax: x (cons top x)) p r))) 868 | 869 | (define (meta-expand-introduce-#%app x p r) 870 | (trace (list 'meta-expand-introduce-#%app x p r)) 871 | ; create new #%app symbol with lexical info from x 872 | (define app (syntax: x '#%app)) 873 | ; if #%app is bound, expand (#%app . x) 874 | (if (unbound? r p app) 875 | (raise (exn:fail:syntax "no #%app bound" (current-continuation-marks) (list x))) 876 | (continue (syntax: x (cons app x)) p r))) 877 | 878 | (define (meta-expand-introduce-#%datum x p r) 879 | (trace (list 'meta-expand-introduce-#%datum x p r)) 880 | ; note #%datum is usually bound to a syntax transformer that 881 | ; expands (#%datum . d) to 'd 882 | (define datum (syntax: x '#%datum)) 883 | (cond [(unbound? r p datum) 884 | (raise (exn:fail:syntax "no #%datum bound" (current-continuation-marks) (list x)))] 885 | [(eq? (syntax-e x) '()) 886 | (raise (exn:fail:syntax "#%app: missing procedure expression" 887 | (current-continuation-marks) (list x)))] 888 | [else 889 | (continue (syntax: x (cons datum x)) p r)])) 890 | 891 | 892 | ;;; 893 | ;;; FORMATTING 894 | ;;; 895 | 896 | (define (~b b) ; ~b for binding 897 | (cond 898 | [(list? b) (map ~mpi b)] 899 | [else (error)])) 900 | 901 | (define (~mpi x) 902 | (define (resolve mpi) (resolve-module-path-index mpi (string->path "xxx"))) 903 | (if (module-path-index? x) 904 | (resolve x) 905 | (~a x))) 906 | 907 | ; ~id : syntax phase -> string 908 | (define (~id s [p 0]) 909 | (define (resolve mpi) (resolve-module-path-index mpi (string->path "xxx"))) 910 | (list (syntax-e s) 911 | (match (identifier-binding s p) 912 | ; #f = top-level or unbound 913 | [(and it (or #f 'lexical)) it] 914 | ; module binding 915 | [(and it (list src-mpi src-sym nom-mpi nom-sym src-phase import-phase nom-export-phase)) 916 | (map (λ(x) (apply-when module-path-index? resolve x)) it)]))) 917 | 918 | ;;; 919 | ;;; LOCAL-EVAL 920 | ;;; 921 | 922 | ; Local evaluation of expressions are needed to evaluate the right hand side of a let-syntax. 923 | 924 | ; local-eval : full-expanded-expression namespace environment -> values 925 | ; evaluate the expression x (a syntax-object representing af fully-expanded expression) 926 | ; where local variable references are resolved in the environment r 927 | ; and global variable references in the namespace ns. 928 | 929 | 930 | ; An environment: 931 | (struct env (bindings parent)) 932 | ; parent = #f is no parent 933 | ; bindings is a list of: 934 | ; (struct binding (label phase type value) #:mutable) 935 | ; label is a symbol (from identifier-binding-symbol) 936 | ; if type is 'lexical, then value is either a box or #f 937 | 938 | (define empty-env (env '() #f)) 939 | (define (make-lexical-binding l p v) 940 | (binding l p 'lexical (box v))) 941 | (define undefined (list 'undefined)) 942 | (define (undefined? o) (eq? o undefined)) 943 | ;(define (add-lexical-binding r l [v undefined]) 'todo) 944 | (define (lexical-store*) 'todo) 945 | 946 | 947 | #;(define (local-eval x r [ns (current-namespace)]) 948 | (define id? identifier?) 949 | (define (lookup x r [ns (current-namespace)]) (error)) 950 | (define (set r ns id v) (error)) 951 | (define (ev* es r) ; es is a non-empty list of expressions 952 | (match es 953 | [(list e) (ev e r)] 954 | [(list* e0 es) (ev e0 r) 955 | (ev* es r)])) 956 | (define (formals-ids fs) 957 | (match fs 958 | [(stx-list ids ...) ids] 959 | [(stx-list-rest ids ... idn) (append ids (list idn))] 960 | [(? id? id) (list id)] 961 | [_ (error)])) 962 | (define (ev x r) 963 | (match x 964 | [(? identifier?) (lookup x r)] 965 | [(stx-list () e0 e1 e2) (if (ev e0 r) (ev e1 r) (ev e2 r))] 966 | [(stx-list () es ... en) (for ([e (in-list es)]) (ev e r)) 967 | (ev en r)] 968 | [(stx-list () e) (ev e r)] 969 | [(stx-list () e0 es ...) (define vs (call-with-values (λ() (ev e0 r)) list)) 970 | (for ([e (in-list es)]) (ev e r)) 971 | (apply values vs)] 972 | [(stx-list () (stx-list [stx-list (stx-list idss) ces] ...) es ..1) 973 | (define vss (for/list ([ce (in-list ces)]) (call-with-values (λ() (ev ce r)) list))) 974 | (ev* es (extend** r idss vss))] 975 | [(stx-list () (stx-list [stx-list (stx-list idss) ces] ...) es ..1) 976 | (define undefss (for/list ([ids (in-list idss)]) (for/list ([id (in-list ids)]) 'undefined))) 977 | (define r* (extend** r idss undefss)) 978 | (for/list ([ids (in-list idss)] [ce (in-list ces)]) 979 | (define vs (call-with-values (λ() (ev ce r)) list)) 980 | (lexical-store* r* ids vs)) 981 | (ev* es r*)] 982 | [(stx-list () (? id? id) e) 983 | (set r ns id (ev e r))] 984 | [(stx-list () d) 985 | d] 986 | [(stx-list () d) 987 | d] 988 | [(stx-list () e0 e1 e2) 989 | (with-continuation-mark (ev e0 r) (ev e1 r) (ev e2 r))] 990 | [(stx-list (<#%plain-app>) e0 es ...) 991 | (apply (ev e0 r) (for/list ([e (in-list es)]) (ev e r)))] 992 | [(stx-cons (<#%top>) (? id? id)) 993 | (namespace-variable-value (identifier-binding-symbol id))] 994 | [(stx-list (<#%variable-reference>) (? id? id)) 995 | (eval `(#%variable-reference ,id))] 996 | [(stx-list (<#%variable-reference>) (stx-cons (<#%top>) (? id? id))) 997 | (eval `(#%variable-reference (#%top ,id)))] 998 | [(stx-list (<#%variable-reference>)) 999 | (eval `(#%variable-reference))] 1000 | [(stx-list (<#%plain-lambda>) formals e) 1001 | (define ids (formals-ids formals)) 1002 | (define closed (λ (vals) (ev e (extend* r ids vals)))) 1003 | (eval `(lambda ,formals (,ev ,@ids)))] 1004 | [_ ; catch forms not yet implemented 1005 | (error)])) 1006 | (ev x r)) 1007 | 1008 | 1009 | 1010 | 1011 | 1012 | 1013 | ;;; 1014 | ;;; TEST 1015 | ;;; 1016 | 1017 | (displayln (with-namespace namespace-here (expand '(#%top . x)))) 1018 | 1019 | (with-namespace namespace-here 1020 | (list 1021 | (and (free-identifier=? (meta-expand 'x) (expand 'x)) 1022 | (bound-identifier=? (meta-expand 'x) (expand 'x))) 1023 | (let ([y 2]) 1024 | (and (free-identifier=? (meta-expand 'x) (expand 'x)) 1025 | (bound-identifier=? (meta-expand 'x) (expand 'x)))))) 1026 | 1027 | (with-namespace namespace-here 1028 | (meta-expand '(+ 1 2))) 1029 | 1030 | ; (meta-expand #'(letrec-syntaxes+values ([(m) (#%plain-lambda (_) #'42)]) () (m))) 1031 | 1032 | -------------------------------------------------------------------------------- /expander/matchers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (for-syntax syntax/parse) 3 | syntax/stx) 4 | 5 | (provide stx-list stx-cons stx-list-rest) 6 | 7 | (define-match-expander stx-list 8 | (lambda (pat-stx) 9 | (syntax-parse pat-stx 10 | [(_ elts ...) 11 | #'(? stx-list? (app stx->list (list elts ...)))] 12 | [_ 13 | (error 'stx-list "error in match pattern" pat-stx)]))) 14 | 15 | (define-match-expander stx-list-rest 16 | (lambda (pat-stx) 17 | (syntax-parse pat-stx 18 | [(_ elts ...) 19 | #'(? stx-pair? (app stx->list-rest (list-rest elts ...)))] 20 | [_ 21 | (error 'stx-list-rest "error in match pattern" pat-stx)]))) 22 | 23 | (define-match-expander stx-cons 24 | (lambda (pat-stx) 25 | (syntax-case pat-stx () 26 | [(_ elt0 elt1) 27 | #'(? stx-pair? (app stx->cons (cons elt0 elt1)))]))) 28 | 29 | (define (stx->cons x) 30 | (cons (stx-car x) (stx-cdr x))) 31 | 32 | (define (stx->list-rest x) 33 | (if (stx-pair? x) 34 | (cons (stx-car x) (stx->list-rest (stx-cdr x))) 35 | x)) 36 | 37 | 38 | ; (provide ...) 39 | 40 | ; syntax: (define-identifier-matcher name id) 41 | ; define name as a match-expander, where 42 | ; (name) matches id 43 | ; (name y) mateches id and binds y to the matched value 44 | ; name is provided 45 | (define-syntax (define-identifier-matcher stx) 46 | (syntax-parse stx 47 | [(_ name id) 48 | #'(begin 49 | (define (predicate? x) 50 | (and (identifier? x) 51 | (bound-identifier=? x id))) 52 | (provide name) 53 | (define-match-expander name 54 | (λ (pat-stx) 55 | (syntax-case pat-stx () 56 | [(_) #'(? predicate?)] 57 | [(_ y) #'(? predicate? y)] 58 | [else (error 'name)]))))])) 59 | 60 | (define-identifier-matcher <#%expression> #'#%expression) 61 | (define-identifier-matcher #'module) 62 | (define-identifier-matcher <#%plain-module-begin> #'plain-module-begin) 63 | (define-identifier-matcher #'begin) 64 | (define-identifier-matcher #'begin-for-syntax) 65 | (define-identifier-matcher <#%provide> #'provide) 66 | (define-identifier-matcher <#%declare> #'#%declare) 67 | (define-identifier-matcher <#%define-values> #'define-values) 68 | (define-identifier-matcher <#%define-syntaxes> #'define-syntaxes) 69 | (define-identifier-matcher <#%require> #'#%require) 70 | (define-identifier-matcher <#%plain-lambda> #'#%plain-lambda) 71 | (define-identifier-matcher #'case-lambda) 72 | (define-identifier-matcher #'if) 73 | (define-identifier-matcher #'begin0) 74 | (define-identifier-matcher #'let-values) 75 | (define-identifier-matcher #'letrec-values) 76 | (define-identifier-matcher #'set!) 77 | (define-identifier-matcher #'quote) 78 | (define-identifier-matcher #'quote-syntax) 79 | (define-identifier-matcher #'with-continuation-mark) 80 | (define-identifier-matcher <#%plain-app> #'#%plain-app) 81 | (define-identifier-matcher <#%top> #'#%top) 82 | (define-identifier-matcher <#%variable-reference> #'#%variable-reference) 83 | 84 | 85 | ;;; The example used to define define-identifier-matcher 86 | #;(define (let-values-keyword? x) 87 | (and (identifier? x) (bound-identifier=? x #'let-values))) 88 | 89 | #;(define-match-expander 90 | (λ (pat-stx) 91 | (syntax-case pat-stx () 92 | [(_) #'(? let-values-keyword?)] 93 | [(_ id) #'(? let-values-keyword? id)] 94 | [else (error)]))) 95 | 96 | ; Test should evaluate to #t 97 | #;(and (match #'x [() #f] [_ #t]) 98 | (match #'let-values [() #t] [_ #f]) 99 | (let ([let-values 1]) 100 | ; let-values is now different from kernel let-values 101 | ; so the following should not match 102 | (and (match #'x [() #f] [_ #t]) 103 | (match #'let-values [() #f] [_ #t])))) 104 | 105 | 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /expander/transformer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide eval-for-meta ; evaluate expression in given phase and return result 3 | eval-for-syntax ; evaluate expression in phase 1 and return result 4 | eval-form-for-meta ; evaluate form in given phase 5 | eval-form-for-syntax ; evaluate form in phase 1 6 | syntax-value ; return the value associated with a syntax binding in a given phase 7 | ) 8 | 9 | (require (for-meta 2 racket/base)) 10 | 11 | ; phase-lift-form : nonnegative-integer s-exp -> s-exp 12 | ; wrap p layers of (begin-for-syntax _) around form 13 | (define (phase-lift-form p form) 14 | (cond [(= p 0) form] 15 | [else (phase-lift-form (- p 1) #`(begin-for-syntax #,form))])) 16 | 17 | ; phase-lift-expression : nonnegative-integer s-exp continuation -> s-exp 18 | ; wrap expr in p let-syntax with a body of `(,return ,expr) 19 | ; When the return result is evaluated, expr gets evaluated in phase p 20 | ; and its return value is passed to return. 21 | (define (phase-lift-expression p expr return) 22 | (define m (gensym 'm)) 23 | (define _ (gensym '_)) 24 | (let loop ([initial #t] [p p] [expr expr]) 25 | (cond [initial (loop #f p #`(#,return #,expr))] 26 | [(= p 0) expr] 27 | [return (loop #f (- p 1) #`(let-syntax ([#,m (lambda (#,_) #,expr)]) (#,m)))]))) 28 | 29 | ; eval-for-meta : phase expression namespace -> value 30 | ; returns the result of evaluating the expression expr 31 | ; in phase p (relative to the current phase) using the namespace ns 32 | (define (eval-for-meta p expr [ns (current-namespace)]) 33 | (let/ec return 34 | (eval (phase-lift-expression p expr return) ns))) 35 | 36 | ; eval-for-syntax : expression namespace escape -> value 37 | ; like eval-for-meta with phase fixed to 1 38 | (define (eval-for-syntax expr [ns (current-namespace)]) 39 | (eval-for-meta 1 expr ns)) 40 | 41 | ; eval-form-for-meta : phase form namespace -> void 42 | ; evaluates the form in phase p using the namespace ns 43 | (define (eval-form-for-meta p form [ns (current-namespace)]) 44 | (eval (phase-lift-form p form) ns)) 45 | 46 | ; eval-form-for-syntax : form namespace -> void 47 | ; like eval-form-for-meta for phase 1 48 | (define (eval-form-for-syntax form [ns (current-namespace)]) 49 | (eval-form-for-meta 1 form ns)) 50 | 51 | ; syntax-value : identifier [namespace] [phase] -> value 52 | ; given an identifier bound to syntax in phase p, 53 | ; return the value to which it is bound 54 | (define (syntax-value id [p 0] [ns (current-namespace)]) 55 | (eval-for-meta (+ p 1) #`(syntax-local-value #'#,id))) 56 | 57 | (define (transformer id [ns (current-namespace)] [p 0]) 58 | (syntax-value id p ns)) 59 | 60 | ;;; 61 | ;;; TESTS 62 | ;;; 63 | 64 | #;( 65 | 66 | (require (for-meta 1 racket/base) 67 | (for-meta 2 racket/base) 68 | (for-meta 3 racket/base)) 69 | 70 | (begin-for-syntax ; phase 1 71 | (begin-for-syntax ; phase 2 72 | (define x 40))) ; define x in phase 2 73 | 74 | ; set current-namespace to "here" (i.e. insides this module) 75 | (define ns (variable-reference->namespace (#%variable-reference))) 76 | (current-namespace ns) 77 | 78 | (eval-form-for-meta 2 '(define y 41)) 79 | (eval-for-meta 2 '(list x y)) 80 | 81 | 82 | 83 | (define t (transformer #'or)) 84 | (define examples (list #'(or) 85 | #'(or x) 86 | #'(or x y) 87 | #'(or x y z) 88 | #'(or x (or y z)))) 89 | 90 | (map (compose1 syntax->datum t) examples) 91 | 92 | ; Result 93 | #;'(#f 94 | (#%expression x) 95 | (let ((or-part x)) (if or-part or-part (or y))) 96 | (let ((or-part x)) (if or-part or-part (or y z))) 97 | (let ((or-part x)) (if or-part or-part (or (or y z))))) 98 | 99 | ) -------------------------------------------------------------------------------- /runtime/commented-decompiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;;; Copy of compiler-pkgs/compiler-lib/compiler/decompile.rkt 3 | ;;; July 17th 2014 - 83a573ccd8b216d9600435692dfa4da851a55d91 4 | 5 | ;;; Goal: Understand how bytecodes work in Racket. 6 | 7 | (require compiler/zo-parse ; parses bytecode to zo structures that represents bytecode 8 | compiler/zo-marshal ; converts zo structures to bytecode 9 | syntax/modcollapse ; used to simplify module paths 10 | racket/port racket/match ; standard racket libraries 11 | racket/list racket/set 12 | racket/path racket/fasl 13 | racket/format) 14 | ;;; 15 | ;;; Overview 16 | ;;; 17 | 18 | ; read compile zo-parse 19 | ; string -> sexp -> bytecode -> bytes -> zo-struct 20 | 21 | ; To produce bytecode for a program, the program needs to be read and compiled. 22 | ; The procedures to are named read and compile. 23 | ; Reading is simple enough, but preparation is need to use the compile procecure. 24 | ; The compiler needs a context to determine the meaning of identifiers. 25 | ; The compile procedure use the current namespace as this context. 26 | ; To compile "(+ 1 2)" in a context where the identifier + is associated to the 27 | ; primitive that performs addition, one must set up a name space and 28 | ; import the primitives (most of which are in the #%kernel module). 29 | 30 | (define (string->bytecode str) 31 | (define ns (make-base-empty-namespace)) 32 | (parameterize ([current-namespace ns]) 33 | (namespace-require ''#%kernel) 34 | (namespace-require 'racket/base) 35 | (define in (open-input-string str)) ; convert string to port 36 | (define s-exp (read in)) ; read 37 | (define bytecode (compile s-exp)) ; compile 38 | bytecode)) 39 | 40 | ; The actual bytecode looks something like this: #~6.0.1.13T ...gibberish... 41 | ; The #~ indicates it is bytecode. The 6.0.1.13 is the version of Racket 42 | ; used to produce the bytecode and then random characters are displayed. 43 | 44 | ; In order to examine the bytecode we need to parse into a more human readable format. 45 | ; The module compiler/zo-parse contains a parser that parses byte strings containing 46 | ; bytecode in to zo-structures. The name zo doesn't mean anything. It is an 47 | ; old pun and stands for Zodiac. Here zo structures simply represents bytecode 48 | ; as structures. 49 | 50 | ; string->zo : string -> zo 51 | (define (string->zo str) 52 | (define bytecode (string->bytecode str)) ; compile to bytecode 53 | (define bs (with-output-to-bytes (λ () (write bytecode)))) ; convert to bytestring 54 | (define zo (zo-parse (open-input-bytes bs))) ; parse to zo structs 55 | zo) 56 | 57 | ;;; Example 58 | 59 | ; > (string->zo "(+ 1 2)") 60 | ; '#s((compilation-top zo 0) 0 #s((prefix zo 0) 0 () ()) 3) 61 | 62 | ; As written it looks a little odd. Normally we write: 63 | ; (compilation-top0 (prefix 0 '() '()) 3) 64 | 65 | ; Here the #s stands for (prefrabricated) structure, which means the system 66 | ; can read and write the structures produced by zo-parse. 67 | 68 | ; Rather than just compilation-top we see (compilation-top zo 0). 69 | ; It simply means that compilation-top has a zo structure as a super type. 70 | ; Note that the zo structure has no fields. 71 | 72 | ; Back to the result of compiling (+ 1 2): 73 | ; (compilation-top0 (prefix 0 '() '()) 3) 74 | ; Where did the +, 1 and 2 go? 75 | ; Well, the compiler determined at compile time that (+ 1 2) gives 3, 76 | ; so the actual bytecode consists of nothing else but the constant 3. 77 | 78 | ;;; Exercise 79 | ; Find a small program which forces the runtime to perform the calcuation (+ 1 2). 80 | ; This attempt failed: 81 | ; > (string->zo "((lambda (x) (+ 1 x)) 2)") 82 | ; '#s((compilation-top zo 0) 0 #s((prefix zo 0) 0 () ()) 3) 83 | 84 | ;;; 85 | ;;; Running bytecode representing zo structures 86 | ;;; 87 | 88 | (define (eval-zo zo) 89 | (fasl->s-exp 90 | (open-input-bytes 91 | (zo-marshal zo)))) 92 | 93 | ; In order to run code represented as zo-structures it must be converted to bytecode. 94 | ; (define bs (zo-marshal (string->zo "(begin (define x 1) x)"))) ; a bytestring of bytecode 95 | ; (fasl->s-exp bs) ; evaluates the bytecode 96 | 97 | ; The following example evaluates to 120. 98 | #;(fasl->s-exp 99 | (open-input-bytes 100 | (zo-marshal 101 | (string->zo 102 | (~a '(let () 103 | (define (fact n) 104 | (if (zero? n) 105 | 1 106 | (* n (fact (- n 1))))) 107 | (fact 5))))))) 108 | 109 | ;;; 110 | ;;; Decompilation 111 | ;;; 112 | 113 | (provide decompile) ; decompile: zo-struct -> s-exp 114 | 115 | ; This module implements the decompile function, which converts 116 | ; the often hard to read zo-structures into a more readable s-exp format. 117 | ; The output of decompile is not meant to be executable. 118 | ; The decompiler is mostly useful for examining bytecode, for example 119 | ; to debug the compiler or to see how which optimizations the compiler 120 | ; performs. 121 | 122 | ;;; 123 | ;;; Primitives 124 | ;;; 125 | 126 | ; Procedures implemented in the C runtime are called primitives. 127 | ; In bytecode they are referred to by index (number). 128 | ; In the output of the decompiler we like to see actual names, 129 | ; so we need a table that maps the index to a name. 130 | ; Introducing new or removing old primitives can change their index, 131 | ; so to avoid changing the table of primitives manually, we do the 132 | ; following: 133 | ; - make a namespace and import all primitives into it 134 | ; by requiring #%kernel, #%unsafe, etc. 135 | ; - for each identifier in the name space, compile a reference to it 136 | ; - see if the result contains (struct primval (n)) 137 | ; - if so the index is n, if not the identifier wasn't bound to a primitive 138 | 139 | ; The result is a table of the form: 140 | ; '#hash((665 . date-time-zone-offset) (794 . exn:fail:contract:divide-by-zero) ...) 141 | 142 | (define primitive-table ; hashtable from index to symbol 143 | (let ([bindings 144 | (let ([ns (make-base-empty-namespace)]) ; make namespace with racket/base attached 145 | (parameterize ([current-namespace ns]) 146 | (namespace-require ''#%kernel) ; import all primitives 147 | (namespace-require ''#%unsafe) 148 | (namespace-require ''#%flfxnum) 149 | (namespace-require ''#%extfl) 150 | (namespace-require ''#%futures) 151 | (namespace-require ''#%foreign) 152 | (for/list ([l (namespace-mapped-symbols)]) ; compile a reference to each symbol 153 | (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) 154 | (compile l))))))] 155 | [table (make-hash)]) 156 | (for ([b (in-list bindings)]) 157 | (let ([v (and (cdr b) 158 | (zo-parse ; parse the bytecode to zo structures 159 | (open-input-bytes 160 | (with-output-to-bytes 161 | (λ () (write (cdr b)))))))]) 162 | (let ([n (match v ; is it a reference to a primitive? 163 | [(struct compilation-top (_ prefix (struct primval (n)))) n] 164 | [else #f])]) 165 | (hash-set! table n (car b))))) ; if so, add it to the table 166 | table)) 167 | 168 | (define (list-ref/protect l pos who) 169 | ; useful for debugging faulty bytecode ... 170 | (list-ref l pos) 171 | #; 172 | (if (pos . < . (length l)) 173 | (list-ref l pos) 174 | `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) 175 | 176 | ;;; 177 | ;;; Decompilation 178 | ;;; 179 | 180 | ; The function zo-parse will parse bytecode and deliver zo-structures 181 | ; representing the bytecode in all detail. The function decompile 182 | ; converts this structure into a human readable s-exp. 183 | 184 | ; The code is written as a recursive descent. To pass along information 185 | ; on globally defined variables, the structure glob-desc is used. 186 | 187 | (define-struct glob-desc (vars num-tls num-stxs num-lifts)) ; explanation follows 188 | ; (num-tls stands for "number of toplevels) 189 | 190 | ; The result of zo-parse is a compilation-top, so that's where the 191 | ; decompilation process begins. 192 | 193 | ; (struct compilation-top zo (max-let-depth prefix code) 194 | 195 | ; The compilation-top consists of code, which are instructions to run on a stack machine. 196 | ; The max-let-depth is maximum stack depth that code creates (not counting the prefix array). 197 | ; The prefix describes what the runtime must push on the stack before executing code. 198 | 199 | (define (decompile top) 200 | (let ([stx-ht (make-hasheq)]) ; hashtable from wraped syntax objects to decompiled ones 201 | (match top 202 | [(struct compilation-top (max-let-depth prefix form)) ; form represents the code to run 203 | ; decompile-prefix returns a description of the global variables 204 | ; and a list of definition that represents ... TODO ... 205 | (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) 206 | `(begin 207 | ,@defns 208 | ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))] 209 | [else (error 'decompile "unrecognized: ~e" top)]))) 210 | 211 | ; (struct prefix zo (num-lifts toplevels stxs) 212 | ; A prefix is an array holding variables. 213 | ; The array is pushed to the stack to initiate evaluation. 214 | 215 | ; Each slot of the array is called a bucket. 216 | ; The buckets are used in this order: 217 | ; toplevels, stxs, maybe one extra bucket, lifted-local-procedures 218 | ; The extra bucket is only used if stxs is non-empty. 219 | ; The number of buckets used for toplevels are (length toplevels) 220 | ; The number of buckets used for stxs are (length stxs) 221 | ; The number of extra buckets are (if (empty? stxs) 0 1) 222 | ; The number of lifted-local-procedures are num-lifts. 223 | ; The length of the array are thus known. 224 | 225 | (define (decompile-prefix a-prefix stx-ht) 226 | (match a-prefix 227 | [(struct prefix (num-lifts toplevels stxs)) 228 | (let ([lift-ids (for/list ([i (in-range num-lifts)]) ; give symbols to local procedures 229 | (gensym 'lift))] 230 | [stx-ids (map (lambda (i) (gensym 'stx)) ; give symbols to stxs 231 | stxs)]) 232 | ; Remember: (define-struct glob-desc (vars num-tls num-stxs num-lifts)) 233 | (values (glob-desc 234 | ; vars = ... 235 | (append 236 | (map (lambda (tl) 237 | (match tl 238 | ; #f represents a dummy variable used to access the enclosing module 239 | [#f '#%linkage] 240 | ; a symbol is a reference to a variable defined in an enclosing module 241 | [(? symbol?) (string->symbol (format "_~a" tl))] 242 | ; top-level variables (appears outside of modules) 243 | [(struct global-bucket (name)) 244 | (string->symbol (format "_~a" name))] 245 | ; variable imported from another module 246 | [(struct module-variable (modidx sym pos phase constantness)) 247 | (if (and (module-path-index? modidx) 248 | (let-values ([(n b) (module-path-index-split modidx)]) 249 | (and (not n) (not b)))) ; n = b = #f represents "self module" 250 | (string->symbol (format "_~a" sym)) ; identifier from this module 251 | (string->symbol 252 | (format "_~s~a@~s~a" ; imported 253 | sym 254 | (match constantness 255 | ['constant ":c"] ; same for every instantiation of its mod 256 | ['fixed ":f"] ; same in a particular module instantiation 257 | [(function-shape a pm?) ; a function 258 | (if pm? ":P" ":p")] ; :P = preserves continuation marks 259 | [(struct-type-shape c) ":t"] 260 | [(constructor-shape a) ":mk"] ; (constructor = make = mk) 261 | [(predicate-shape) ":?"] 262 | [(accessor-shape c) ":ref"] 263 | [(mutator-shape c) ":set!"] 264 | [else ""]) 265 | (mpi->string modidx) ; module name 266 | (if (zero? phase) ; maybe append phase 267 | "" 268 | (format "/~a" phase)))))] 269 | [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) 270 | toplevels) 271 | stx-ids 272 | (if (null? stx-ids) null '(#%stx-array)) 273 | lift-ids) 274 | ; num-tls = 275 | (length toplevels) 276 | ; num-stxs = 277 | (length stxs) 278 | ; num-lifts = 279 | num-lifts) 280 | (map (lambda (stx id) ; we will ignore stxs for the time being 281 | `(define ,id ,(if stx 282 | `(#%decode-syntax 283 | ,(decompile-stx (stx-encoded stx) stx-ht)) 284 | #f))) 285 | stxs stx-ids)))] 286 | [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) 287 | 288 | ; The function decompile-stx transforms the representation of syntax-objects 289 | ; used by zo-parse to mutable lists that besides the syntax object also 290 | ; shows lexical information. 291 | ; > (decompile-stx (wrapped #'(a b c) '() 'clean) (make-hash)) 292 | ; (mcons 'wrap (mcons # '())) 293 | (define (decompile-stx stx stx-ht) 294 | (or (hash-ref stx-ht stx #f) 295 | (let ([p (mcons #f #f)]) 296 | (hash-set! stx-ht stx p) 297 | (match stx 298 | [(wrapped datum wraps tamper-status) 299 | (set-mcar! p (case tamper-status 300 | [(clean) 'wrap] 301 | [(tainted) 'wrap-tainted] 302 | [(armed) 'wrap-armed])) 303 | (set-mcdr! p (mcons 304 | (cond 305 | [(pair? datum) 306 | (cons (decompile-stx (car datum) stx-ht) 307 | (let loop ([l (cdr datum)]) 308 | (cond 309 | [(null? l) null] 310 | [(pair? l) 311 | (cons (decompile-stx (car l) stx-ht) 312 | (loop (cdr l)))] 313 | [else 314 | (decompile-stx l stx-ht)])))] 315 | [(vector? datum) 316 | (for/vector ([e (in-vector datum)]) 317 | (decompile-stx e stx-ht))] 318 | [(box? datum) 319 | (box (decompile-stx (unbox datum) stx-ht))] 320 | [else datum]) 321 | (let loop ([wraps wraps]) 322 | (cond 323 | [(null? wraps) null] 324 | [else 325 | (or (hash-ref stx-ht wraps #f) 326 | (let ([p (mcons #f #f)]) 327 | (hash-set! stx-ht wraps p) 328 | (set-mcar! p (decompile-wrap (car wraps) stx-ht)) 329 | (set-mcdr! p (loop (cdr wraps))) 330 | p))])))) 331 | p])))) 332 | 333 | (define (decompile-wrap w stx-ht) 334 | (or (hash-ref stx-ht w #f) 335 | (let ([v (match w 336 | [(lexical-rename has-free-id-renames? 337 | ignored 338 | alist) 339 | `(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)] 340 | [(phase-shift amt src dest cancel-id) 341 | `(phase-shift ,amt ,src ,dest, cancel-id)] 342 | [(wrap-mark val) 343 | val] 344 | [(prune sym) 345 | `(prune ,sym)] 346 | [(module-rename phase kind set-id unmarshals renames mark-renames plus-kern?) 347 | `(module-rename ,phase ,kind ,set-id ,unmarshals ,renames ,mark-renames ,plus-kern?)] 348 | [(top-level-rename flag) 349 | `(top-level-rename ,flag)] 350 | [else w])]) 351 | (hash-set! stx-ht w v) 352 | v))) 353 | 354 | (define (mpi->string modidx) 355 | (cond 356 | [(symbol? modidx) modidx] 357 | [else 358 | (collapse-module-path-index modidx (build-path 359 | (or (current-load-relative-directory) 360 | (current-directory)) 361 | "here.rkt"))])) 362 | 363 | ; (struct mod (name srcname ...)) 364 | ; Represents a module declaration. 365 | 366 | ;> (decompile (string->zo "(module foo racket (+ 1 2))")) 367 | ;'(begin 368 | ; (module foo .... 369 | ; (require (lib "racket/main.rkt")) 370 | ; (module configure-runtime .... 371 | ; (require '#%kernel (lib "racket/runtime-config.rkt")) 372 | ; (|_configure:p@(lib "racket/runtime-config.rkt")| '#f)) 373 | ; (#%apply-values |_print-values:p@(lib "racket/private/modbeg.rkt")| '3))) 374 | 375 | (define (decompile-module mod-form orig-stack stx-ht mod-name) 376 | (match mod-form 377 | [(struct mod (name ; symbol => module name 378 | ; ; list of symbols => submodule , '(foo bar) is submodule bar inside foo 379 | srcname ; symbol e.g. bar for the submodule bar in foo 380 | self-modidx ; the module path index 381 | prefix ; a prefix pushed before evaluation of the body 382 | provides ; association list from phases to exports 383 | requires ; association list from phases to imports 384 | body ; code for phase 0 385 | syntax-bodies ; syntax-bodies use their own prefix 386 | unexported ; list of lists of symbols, for unexported definitions 387 | ; ; these can be accessed during macro expansion 388 | max-let-depth ; max stack depth created by body forms (not counting prefix) 389 | dummy ; access to the top-level namespace 390 | lang-info ; optional module-path for info (used by module->lang-info) 391 | internal-context ; internal-module-context lexical context of the body 392 | ; ; #t #f stx or vector of stx 393 | flags ; list of symbols, there 'cross-phase indicates the module-body 394 | ; ; is evaluated once and results shared across all phases 395 | pre-submodules ; module declared submodules 396 | post-submodules ; module* declared submodules 397 | )) 398 | (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] 399 | [(stack) (append '(#%modvars) orig-stack)] 400 | ; a module declaration pushes an array on stack containing 401 | ; the module variables so '#%modvars is consed to the stack as a place holder 402 | [(closed) (make-hasheq)]) ; 403 | `(,mod-name ,(if (symbol? name) name (last name)) 404 | .... ; indicate the place where language name is (replaced with explicit requires) 405 | ; The submodule baz in submodule bar in module foo is '(foo bar baz). 406 | ; so (last name) gets the name of the submodule. 407 | ,@(if (null? flags) '() (list `(quote ,flags))) ; if present show flags 408 | ; now the list of requires 409 | ,@(let ([l (apply 410 | append 411 | (for/list ([req (in-list requires)] 412 | #:when (pair? (cdr req))) 413 | ; produce list of symbols and/or module paths as strings 414 | (define l (for/list ([mpi (in-list (cdr req))]) 415 | (define p (mpi->string mpi)) 416 | (if (path? p) 417 | (let ([d (current-load-relative-directory)]) 418 | (path->string 419 | (if d 420 | (find-relative-path (simplify-path d #t) 421 | (simplify-path p #f) 422 | #:more-than-root? #t) 423 | p))) 424 | p))) 425 | (if (eq? 0 (car req)) ; phase 0 just use as is 426 | l 427 | `((,@(case (car req) 428 | [(#f) `(for-label)] ; phase #f means for-label 429 | [(1) `(for-syntax)] ; phase 1 for-syntax 430 | [else `(for-meta ,(car req))]); otherwise use for-meta 431 | ,@l)))))]) 432 | (if (null? l) null `((require ,@l)))) 433 | ; the definitions from the decompilation of the prefix: 434 | ,@defns 435 | ; the module declared submodules: 436 | ,@(for/list ([submod (in-list pre-submodules)]) 437 | (decompile-module submod orig-stack stx-ht 'module)) 438 | ; the syntax-bodies 439 | ,@(for/list ([b (in-list syntax-bodies)]) 440 | (let loop ([n (sub1 (car b))]) 441 | (if (zero? n) 442 | (cons 'begin 443 | (for/list ([form (in-list (cdr b))]) 444 | (decompile-form form globs stack closed stx-ht))) 445 | (list 'begin-for-syntax (loop (sub1 n)))))) 446 | ; the form 447 | ,@(map (lambda (form) 448 | (decompile-form form globs stack closed stx-ht)) 449 | body) 450 | ; and finally the module* declared sudmodules 451 | ,@(for/list ([submod (in-list post-submodules)]) 452 | (decompile-module submod orig-stack stx-ht 'module*))))] 453 | [else (error 'decompile-module "huh?: ~e" mod-form)])) 454 | 455 | ; (struct form zo ()) 456 | ; Form is the super-type for all form that can appear in compiled code 457 | ; except for literals that are represented as themselves. 458 | 459 | ; decompile-form : form glob-desc stack closed stx-ht -> s-exp 460 | ; globs = (glob-desc vars num-tls num-stxs num-lifts)) produced by decompile-prefix 461 | ; stack = a list of symbols representing the contents of the stack 462 | ; the top of the stack has index 0 463 | ; closed = is an hasheq-table from ... to ... 464 | ; stx-ht = is a hashtable from wrapped syntax objects to decompiled syntax objects 465 | (define (decompile-form form globs stack closed stx-ht) 466 | (match form 467 | [(? mod?) 468 | (decompile-module form stack stx-ht 'module)] 469 | [(struct def-values (ids rhs)) 470 | ; Each id is a toplevel: (struct toplevel expr (depth pos const? ready?)) 471 | ; A toplevel represents a reference to a top-level or imported variable via the prefix array. 472 | ; The depth field indicates the number of stack slots to skip to reach the prefix array, 473 | ; and pos is the offset into the array. 474 | `(define-values ,(map (lambda (tl) 475 | (match tl 476 | [(struct toplevel (depth pos const? set-const?)) 477 | ; here pos is used to find the identifier 478 | ; (but depth is not used) 479 | (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) 480 | ids) 481 | ,(if (inline-variant? rhs) ; an inline-variabn can be used for cross-module inlining 482 | `(begin ; if present there is both an inline and a direct variant 483 | ,(list 'quote '%%inline-variant%%) 484 | ,(decompile-expr (inline-variant-inline rhs) globs stack closed) 485 | ,(decompile-expr (inline-variant-direct rhs) globs stack closed)) 486 | (decompile-expr rhs globs stack closed)))] 487 | [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) 488 | ; def-syntaxes uses their own prefix, so "install" it and then do as in def-values 489 | `(define-syntaxes ,ids 490 | ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) 491 | `(let () 492 | ,@defns 493 | ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] 494 | [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) 495 | ; a define-syntaxes or begin-for-syntax form, decompile both to (begin-for-syntax ...) 496 | `(begin-for-syntax 497 | ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) 498 | `(let () 499 | ,@defns 500 | ,@(for/list ([rhs (in-list exprs)]) 501 | (decompile-form rhs globs '(#%globals) closed stx-ht)))))] 502 | [(struct seq (forms)) 503 | ; represents a begin or splice form 504 | `(begin ,@(map (lambda (form) 505 | (decompile-form form globs stack closed stx-ht)) 506 | forms))] 507 | [(struct splice (forms)) 508 | `(begin ,@(map (lambda (form) 509 | (decompile-form form globs stack closed stx-ht)) 510 | forms))] 511 | [(struct req (reqs dummy)) 512 | ; a top-level require (but not in a module form) 513 | `(#%require . (#%decode-syntax ,reqs))] 514 | [else 515 | (decompile-expr form globs stack closed)])) 516 | 517 | (define (extract-name name) 518 | (if (symbol? name) 519 | (gensym name) 520 | (if (vector? name) 521 | (gensym (vector-ref name 0)) 522 | #f))) 523 | 524 | (define (extract-id expr) 525 | (match expr 526 | [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map 527 | max-let-depth body)) 528 | (extract-name name)] 529 | [(struct case-lam (name lams)) 530 | (extract-name name)] 531 | [(struct closure (lam gen-id)) 532 | (extract-id lam)] 533 | [else #f])) 534 | 535 | (define (extract-ids! body ids) 536 | ; used to decompile let-void which pushes an number of uninitilized slots on the stack 537 | ; while decompiling (struct let-void (count boxes? body)) the call 538 | ; (extract-ids! body ids) is made to fill in the vector ids of identifiers 539 | ; the ids are generated elsewhere, so they need to be extracted 540 | (match body 541 | [(struct let-rec (procs body)) 542 | (for ([proc (in-list procs)] 543 | [delta (in-naturals)]) 544 | (when (< -1 delta (vector-length ids)) 545 | (vector-set! ids delta (extract-id proc)))) 546 | (extract-ids! body ids)] 547 | [(struct install-value (val-count pos boxes? rhs body)) 548 | (extract-ids! body ids)] 549 | [(struct boxenv (pos body)) 550 | (extract-ids! body ids)] 551 | [else #f])) 552 | 553 | (define (decompile-tl expr globs stack closed no-check?) 554 | (match expr 555 | [(struct toplevel (depth pos const? ready?)) 556 | ; Represents a reference to a top-level or imported variable via the prefix array. 557 | (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)]) ; pos index in prefix array 558 | (cond 559 | ; references to potentially uninitialized slots mut be checked, see if a check is needed: 560 | [no-check? id] 561 | [(and (not const?) (not ready?)) 562 | `(#%checked ,id)] 563 | #;[(and const? ready?) `(#%const ,id)] 564 | #;[const? `(#%iconst ,id)] 565 | [else id]))])) 566 | 567 | (define (decompile-expr expr globs stack closed) 568 | (match expr 569 | [(struct toplevel (depth pos const? ready?)) 570 | (decompile-tl expr globs stack closed #f)] 571 | [(struct varref (tl dummy)) 572 | `(#%variable-reference ,(if (eq? tl #t) ; original reference was to a contant local binding 573 | ' 574 | (decompile-tl tl globs stack closed #t)))] 575 | [(struct topsyntax (depth pos midpt)) 576 | ; Represents a reference to a quoted syntax object via the prefix array. 577 | (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] 578 | [(struct primval (id)) 579 | ; Represents a direct reference to a variable imported from the run-time kernel. 580 | (hash-ref primitive-table id (lambda () (error "unknown primitive")))] 581 | [(struct assign (id rhs undef-ok?)) 582 | ; Represents a set! expression that assigns to a top-level or module-level variable. 583 | ; (Assignments to local variables are represented by install-value expressions.) 584 | ; After rhs is evaluated, the stack is restored to its depth from before evaluating rhs. 585 | `(set! ,(decompile-expr id globs stack closed) 586 | ,(decompile-expr rhs globs stack closed))] 587 | [(struct localref (unbox? offset clear? other-clears? type)) 588 | ; Represents a local-variable reference; 589 | ; it accesses the value in the stack slot after the first pos slots. 590 | (let ([id (list-ref/protect stack offset 'localref)]) 591 | (let ([e (if unbox? ; unbox if needed 592 | `(#%unbox ,id) 593 | id)]) 594 | (if clear? ; clear if needed (to allow reclamation of the value as garbage) 595 | `(#%sfs-clear ,e) 596 | e)))] 597 | [(? lam?) 598 | `(lambda . ,(decompile-lam expr globs stack closed))] 599 | [(struct case-lam (name lams)) 600 | ; Represents a case-lambda form as a combination of lambda forms that are tried (in order) 601 | ; based on the number of arguments given. 602 | `(case-lambda 603 | ,@(map (lambda (lam) 604 | (decompile-lam lam globs stack closed)) 605 | lams))] 606 | [(struct let-one (rhs body type unused?)) 607 | ; Pushes an uninitialized slot onto the stack, evaluates rhs and 608 | ; puts its value into the slot, and then runs body. 609 | ; type is one of #f 'flonum 'fixnum 'extflonum 610 | ; If type is not #f, then rhs must produce a value of the corresponding type, 611 | ; and the slot must be accessed by localrefs that expect the type. 612 | ; Restores stack depth. 613 | (let ([id (or (extract-id rhs) 614 | (gensym (or type (if unused? 'unused 'local))))]) 615 | `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) 616 | ,(decompile-expr body globs (cons id stack) closed)))] 617 | [(struct let-void (count boxes? body)) 618 | ; Pushes count uninitialized slots onto the stack and then runs body. 619 | ; If boxes? is #t, then the slots are filled with boxes that contain #. 620 | (let ([ids (make-vector count #f)]) 621 | (extract-ids! body ids) 622 | (let ([vars (for/list ([i (in-range count)] 623 | [id (in-vector ids)]) 624 | (or id (gensym (if boxes? 'localvb 'localv))))]) 625 | `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) 626 | vars) 627 | ,(decompile-expr body globs (append vars stack) closed))))] 628 | [(struct let-rec (procs body)) 629 | ; Represents a letrec form with lambda bindings: 630 | ; (letrec ([id (lambda ...)] ...) body) 631 | `(begin 632 | (#%set!-rec-values ,(for/list ([p (in-list procs)] 633 | [i (in-naturals)]) 634 | (list-ref/protect stack i 'let-rec)) 635 | ,@(map (lambda (proc) 636 | (decompile-expr proc globs stack closed)) 637 | procs)) 638 | ,(decompile-expr body globs stack closed))] 639 | [(struct install-value (count pos boxes? rhs body)) 640 | ; Runs rhs to obtain count results, and installs them into existing slots on the stack in order, 641 | ; skipping the first pos stack positions. 642 | `(begin 643 | (,(if boxes? '#%set-boxes! 'set!-values) 644 | ,(for/list ([i (in-range count)]) 645 | (list-ref/protect stack (+ i pos) 'install-value)) 646 | ,(decompile-expr rhs globs stack closed)) 647 | ,(decompile-expr body globs stack closed))] 648 | [(struct boxenv (pos body)) 649 | ; Skips pos elements of the stack, setting the slot afterward to a new box containing 650 | ; the slot’s old value, and then runs body. 651 | (let ([id (list-ref/protect stack pos 'boxenv)]) 652 | `(begin 653 | (set! ,id (#%box ,id)) 654 | ,(decompile-expr body globs stack closed)))] 655 | [(struct branch (test then else)) 656 | `(if ,(decompile-expr test globs stack closed) 657 | ,(decompile-expr then globs stack closed) 658 | ,(decompile-expr else globs stack closed))] 659 | [(struct application (rator rands)) 660 | ; Represents a function call. The rator field is the expression for the function, 661 | ; and rands are the argument expressions. 662 | ; Before any of the expressions are evaluated, (length rands) uninitialized stack slots 663 | ; are created (to be used as temporary space). 664 | (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) ; push slots 665 | stack)]) 666 | (annotate-unboxed 667 | rands 668 | (annotate-inline 669 | `(,(decompile-expr rator globs stack closed) 670 | ,@(map (lambda (rand) 671 | (decompile-expr rand globs stack closed)) 672 | rands)))))] 673 | [(struct apply-values (proc args-expr)) 674 | `(#%apply-values ,(decompile-expr proc globs stack closed) 675 | ,(decompile-expr args-expr globs stack closed))] 676 | [(struct seq (exprs)) 677 | `(begin ,@(for/list ([expr (in-list exprs)]) 678 | (decompile-expr expr globs stack closed)))] 679 | [(struct beg0 (exprs)) 680 | ; restores stack depth 681 | `(begin0 ,@(for/list ([expr (in-list exprs)]) 682 | (decompile-expr expr globs stack closed)))] 683 | [(struct with-cont-mark (key val body)) 684 | `(with-continuation-mark 685 | ,(decompile-expr key globs stack closed) 686 | ,(decompile-expr val globs stack closed) 687 | ,(decompile-expr body globs stack closed))] 688 | [(struct closure (lam gen-id)) 689 | ; A lambda form with an empty closure, which is a procedure constant. 690 | (if (hash-ref closed gen-id #f) ; generate an identifier and save it for later use in closed 691 | gen-id 692 | (begin 693 | (hash-set! closed gen-id #t) 694 | `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] 695 | ; and finally literals 696 | [else `(quote ,expr)])) 697 | 698 | (define (decompile-lam expr globs stack closed) 699 | (match expr 700 | [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] 701 | [(struct lam (name ; for debugging purposes 702 | flags ; 'preserves-marks 'is-method 'single-result 703 | ; 'only-rest-arg-not-used 'sfs-clear-rest-args 704 | num-params ; number of arguments accepted by the procedure, 705 | ; ; not counting a rest argument 706 | arg-types ; (listof (or/c 'val 'ref 'flonum 'fixnum 'extflonum)) 707 | ; ; 'val = normal argument, 'ref = boxed 708 | rest? ; are rest arguments accepted? if so they are 709 | ; ; collected into a "rest" variable 710 | closure-map ; vector of stack-positions captured when lambda is evaluated 711 | closure-types ; types corresponding to the captured variables 712 | tl-map ; indicates which toplevel variables actually used 713 | max-let-depth ; indicates the maximum stack depth created by body plus 714 | ; ; the arguments and closure-captured values pushed onto the stack 715 | body)) ; expr 716 | (let ([vars (for/list ([i (in-range num-params)] 717 | [type (in-list arg-types)]) 718 | (gensym (format "~a~a-" 719 | (case type 720 | [(ref) "argbox"] 721 | [(val) "arg"] 722 | [else (format "arg~a" type)]) 723 | i)))] 724 | [rest-vars (if rest? (list (gensym 'rest)) null)] 725 | [captures (map (lambda (v) 726 | (list-ref/protect stack v 'lam)) 727 | (vector->list closure-map))]) 728 | ; the lambda / case-lambda are consed elsewhere, so begin with the argument list: 729 | `((,@vars . ,(if rest? 730 | (car rest-vars) 731 | null)) 732 | ; the name for debugging purposes 733 | ,@(if (and name (not (null? name))) 734 | `(',name) 735 | null) 736 | ; flags 737 | ,@(if (null? flags) null `('(flags: ,@flags))) 738 | ; list the captures 739 | ,@(if (null? captures) 740 | null 741 | `('(captures: ,@(map (lambda (c t) 742 | (if t 743 | `(,t ,c) 744 | c)) 745 | captures 746 | closure-types) 747 | ,@(if (not tl-map) 748 | '() 749 | (list 750 | (for/list ([pos (in-set tl-map)]) 751 | (list-ref/protect (glob-desc-vars globs) 752 | (if (or (pos . < . (glob-desc-num-tls globs)) 753 | (zero? (glob-desc-num-stxs globs))) 754 | pos 755 | (+ pos (glob-desc-num-stxs globs) 1)) 756 | 'lam))))))) 757 | ,(decompile-expr body globs 758 | (append captures 759 | (append vars rest-vars)) 760 | closed)))])) 761 | 762 | (define (annotate-inline a) 763 | a) 764 | 765 | (define (annotate-unboxed args a) 766 | a) 767 | 768 | ;; ---------------------------------------- 769 | 770 | #; 771 | (begin 772 | (require scheme/pretty) 773 | (define (try e) 774 | (pretty-print 775 | (decompile 776 | (zo-parse (let-values ([(in out) (make-pipe)]) 777 | (write (parameterize ([current-namespace (make-base-namespace)]) 778 | (compile e)) 779 | out) 780 | (close-output-port out) 781 | in))))) 782 | (pretty-print 783 | (decompile 784 | (zo-parse 785 | (open-input-file 786 | "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo")))) 787 | #; 788 | (try '(lambda (q . more) 789 | (letrec ([f (lambda (x) f)]) 790 | (lambda (g) f))))) -------------------------------------------------------------------------------- /runtime/racket-eval.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; HISTORY 4 | ;; 2016-July-22 5 | ;; - removed dependcy on unstable/syntax 6 | ;; - fixed handling of compilation-top and prefix 7 | ;; (since 2014: 8 | ;; compilation-top has gained the field binding-namess 9 | ;; and prefix has gained the field src-inspector-desc 10 | 11 | ;;; Jens Axel Søgaard, July 2014 12 | ;;; Goal: Understand how bytecodes work in Racket. 13 | ;;; Make an interpreter for bytecodes in Racket. 14 | 15 | ;;; Features 16 | ; * All bytecodes are implemented 17 | ; * Explicit simulation of the stack and the use of prefix arrays 18 | ; * Multiple values are supported 19 | ; * Explicit allocation of closures from lambda, case-lambda and let-rec respectively. 20 | ; * Closures can be applied by Racket procedures such as map and apply 21 | ; * Top-level variables are represented as a standard namespace 22 | ; * Modules represented as standard modules 23 | ; * Import from standard Racket modules are supported 24 | ; * Exports are supported (rename-out is not supported though) 25 | 26 | ;;; Missing 27 | ; * Submodules ignored for now 28 | 29 | ; * Primitives that manipulate the (Racket) stack need to be overridden 30 | ; so they know about the simulated stack. 31 | ; (That is call/cc, dynamic-wind are out of order) 32 | 33 | ; * Use eval-zo directly in the DrRacket repl [easy fix] 34 | ; [ (current-eval eval-zo) fails: real eval calls (current-eval ] 35 | 36 | ;;; Ideas for further exploration 37 | ; * Increase detail of simulation: 38 | ; - Multiple values 39 | ; - Implement namespace and module registry 40 | ; - continuation marks 41 | ; - dynamic-wind, prompts and continuations 42 | 43 | (provide (all-defined-out)) 44 | 45 | ;;; 46 | ;;; Imports 47 | ;;; 48 | (require compiler/zo-structs ; structures definitions for zo-structs (represents bytecode) 49 | compiler/zo-parse ; parses bytecode to zo structures that represents bytecode 50 | compiler/zo-marshal ; converts zo to bytecode 51 | racket/fasl ; (unused) converts bytecode in byte string for to s-exp 52 | compiler/decompile ; converts zo to human readable s-exp 53 | racket/undefined ; (could be) used to fill uninitialized slots 54 | syntax/modcollapse ; used to simplify module paths 55 | ; syntax/modread ; (unused) read modules 56 | syntax/modresolve ; resolving module paths to file paths 57 | ; standard racket libraries 58 | racket/port racket/match racket/list racket/path racket/format 59 | ; a couple of test macros use syntax/parse 60 | (for-syntax syntax/parse racket/base)) 61 | 62 | ; SYNTAX (phase-of-enclosing-module) 63 | ; Returns the phase level of the module in which the form occurs 64 | ; (and for the instantiation of the module in which the form is executed). 65 | ; For example, if a module is required directly by the “main” module 66 | ; (or the top level), its phase level is 0. If a module is required for-syntax 67 | ; by the “main” module (or the top level), its phase level is 1. 68 | ; (This used to be in unstable/syntax) 69 | (define-syntax-rule (phase-of-enclosing-module) 70 | (variable-reference->module-base-phase (#%variable-reference))) 71 | 72 | ;;; 73 | ;;; OVERVIEW 74 | ;;; 75 | 76 | ; The procedures read and compile are enough to produce raw bytecode. 77 | ; (compile (read (open-input-string "(+ 1 2)"))) 78 | ; The result of compile is a compiled-expression and is basically a byte string. 79 | ; We want to work with structures representing the bytecode. 80 | ; The module compiler/zo-structs contain structure definitions used to 81 | ; represent the bytecode as structs. The structures are named zo structs or 82 | ; just zo for short. 83 | ; The module compiler/zo-parse contains a parser that produce zo structures. 84 | 85 | ; Standard evaluation of a piece of text read from a port undergoes this process. 86 | 87 | ; Operation: read expand compile eval 88 | ; Type: port -> s-exp -> syntax -> bytecode -> value 89 | 90 | ; [Aside: Internally eval generates machine code from the bytecode, 91 | ; which is executed to produce the values.] 92 | 93 | ; It doesn't take long to realize that 94 | 95 | ; (eval (compile (expand (read (open-input-string "(+ 1 2)"))))) 96 | 97 | ; is bothersome to type over and over again while testing an interpreter. 98 | ; Consequently eval will automatically invoke the invoke the expander and compiler. 99 | 100 | ; Note: (eval s-exp) 101 | ; = (eval (compile s-exp)) 102 | ; = (eval (compile (expand s-exp))) 103 | 104 | ; The example now becomes: (eval '(+ 1 2)) 105 | 106 | ; The function compile produce bytecode. 107 | ; The actual bytecode looks something like this: #~6.0.1.13T ...gibberish... 108 | ; The #~ indicates it is bytecode. The 6.0.1.13 is the version of Racket 109 | ; used to produce the bytecode and then random characters are displayed. 110 | 111 | ; In order to examine the bytecode we need to parse into a more human readable format. 112 | ; The module compiler/zo-parse contains a parser that parses byte strings containing 113 | ; bytecode in to zo-structures. The name zo doesn't mean anything. It is an 114 | ; old pun and stands for Zodiac. Here zo structures simply represents bytecode 115 | ; as structures. 116 | 117 | ; The evaluator eval-zo implemented here use zo as input. A parser 118 | ; from bytecode to zo is needed. The parser zo-parse from compiler/zo-parse 119 | ; parses from byte strings to zo. A little step to convert from 120 | ; bytecode to byte string is needed. 121 | 122 | ; Operation: expand compile convert zo-parse eval-zo 123 | ; Type: s-exp -> syntax -> bytecode -> bytes -> zo -> value 124 | 125 | ; convert : bytecode -> bytes 126 | (define (convert bytecode) 127 | (open-input-bytes (with-output-to-bytes (λ () (write bytecode))))) 128 | 129 | ; Since expander, compiler and evaluator work together, we will define 130 | ; our own set: 131 | ; expand-zo : expands s-exp to syntax object 132 | ; compile-zo : compiles syntax-object to zo 133 | ; (if given an s-exp it invokes expand-zo) 134 | ; (if given bytecode it invokes convert) 135 | ; eval-zo : evaluates zo 136 | ; (if given an something else, compile-zo is invoked) 137 | 138 | ; [We will soon get to actual code, but we need an aside first.] 139 | 140 | ;;; 141 | ;;; NAMESPACES 142 | ;;; 143 | 144 | ; The function read needs no context to parse a string "(+ 1 2)" into '(+ 1 2). 145 | ; The functions expand, compile and eval all need to happen in a context. 146 | ; To evaluate '(+ 1 2) there needs to association between the '+ and the 147 | ; primitive addition operation. 148 | 149 | ; Standard Racket use namespaces to represent such associations 150 | ; and we will use these as-is. 151 | ; A namespace must not be confused with an environment. 152 | ; A namespace is a *top-level* mapping from symbols to identifiers. 153 | ; That is: local variables are not stored in the namespace. 154 | 155 | ; Expand uses the namespace given by the parameter current-namespace. 156 | ; Let's see the effect it has on expansion: 157 | ; > (parameterize ([current-namespace (make-empty-namespace)]) (expand '(+ 1 2))) 158 | ; +: unbound identifier; 159 | ; In an empty namespace + has no binding, so we get an error. 160 | ; In a #lang racket repl, we get: 161 | ; > (expand '(+ 1 2)) 162 | ; 163 | 164 | ; Since we will be do a *lot* of testing in the DrRacket repl, it is 165 | ; not ideal to use the more-or-less random namespace in current-namespace. 166 | ; At least not in the beginning. Our standard namespace for testing 167 | ; will be produced by make-start-namespace and used automatically 168 | ; by expand-zo, compile-zo and eval-zo. If we use DrRacket's 169 | ; current-namespace we will compile will error-tracing enabled, 170 | ; which will make our first programs more complicated than need be. 171 | 172 | ; Well, later it becomes important for evaluation to use the 173 | ; same namespace as compile - at that point the current-namespace 174 | ; convention is the right thing. 175 | 176 | (define use-start-or-current 'start) 177 | (define (use-start) (set! use-start-or-current 'start)) 178 | (define (use-current) (set! use-start-or-current 'current)) 179 | 180 | ; make-start-namespace : -> namespace 181 | ; like make-base-empty-namespace but also attaches 'racket/list 182 | (define (make-start-namespace) 183 | (case use-start-or-current 184 | [(start) (define ns (make-base-empty-namespace)) 185 | (parameterize ([current-namespace ns]) 186 | ; The start-namespace imports #%kernel 187 | ; contains most of the primitives in Racket. 188 | (namespace-require ''#%kernel) 189 | (namespace-require 'racket/base) 190 | ; racket/list is imported to make tests more interesting 191 | ; The racket/list module provides procedures implemented in Racket 192 | ; (we need to test that application works with both primitives and procedures) 193 | (namespace-require/copy 'racket/list)) 194 | ns] 195 | [(current) (current-namespace)] 196 | [else (error 'make-start-namespace "expected 'start or 'current in use-start-or-current")])) 197 | 198 | ; A little syntax makes life sweeter. 199 | 200 | ; syntax: (with-start-namespace body ...) 201 | ; Parameterize current-namespace with the result of (make-start-namespace) 202 | ; and evaluate the bodies. The result of the last body is returned. 203 | (define-syntax (with-start-namespace stx) 204 | (syntax-parse stx 205 | [(_ body ...+) 206 | #'(parameterize ([current-namespace (make-start-namespace)]) 207 | body ...)])) 208 | 209 | ; syntax: (start-begin form ...) 210 | ; Evaluate each form ... in order were the parameter current-namespace 211 | ; is set to the result of (make-start-namespace). 212 | (define-syntax (start-begin stx) 213 | (syntax-parse stx 214 | [(_ form ...) 215 | #'(begin (with-start-namespace form ...))])) 216 | 217 | ;;; 218 | ;;; EXPANSION 219 | ;;; 220 | 221 | (define (expand-zo s-exp [ns (make-start-namespace)]) 222 | (parameterize ([current-namespace ns]) 223 | (expand s-exp))) 224 | 225 | ;;; 226 | ;;; COMPILATION 227 | ;;; 228 | 229 | ; Here are the basic operations we will use: 230 | 231 | ; Operation: s-exp->bytecode bytecode->zo 232 | ; Type: sexp -> bytecode -> zo 233 | 234 | (define bytecode? compiled-expression?) 235 | 236 | ; compile-zo : (or/c s-exp bytecode?) [namespace] -> zo 237 | (define (compile-zo s-exp [ns (make-start-namespace)]) 238 | (parameterize ([current-namespace ns] 239 | ; we allow set! to undefined variables, due to the way we 240 | ; implement modules [see eval-module] 241 | [compile-allow-set!-undefined #f]) 242 | (match s-exp 243 | [(? bytecode? bc) (bytecode->zo bc)] 244 | [_ (define bc (s-exp->bytecode s-exp ns)) 245 | (bytecode->zo bc)]))) 246 | 247 | (define (s-exp->bytecode s-exp [ns (make-start-namespace)]) 248 | (parameterize ([current-namespace ns] 249 | [compile-allow-set!-undefined #f]) 250 | (compile s-exp))) 251 | 252 | (define (bytecode->zo bytecode) 253 | (zo-parse (convert bytecode))) 254 | 255 | ;;; Example 256 | 257 | ; We are finally in a position to sudy some real bytecode. 258 | 259 | ; > (compile-zo '(+ 1 2)) 260 | ; '#s((compilation-top zo 0) 0 #s((prefix zo 0) 0 () ()) 3) 261 | 262 | ; As written it looks a little odd. Normally we write: 263 | ; (compilation-top0 (prefix 0 '() '()) 3) 264 | 265 | ; Here the #s stands for (prefrabricated) structure, which means the system 266 | ; can read and write the structures produced by zo-parse. 267 | 268 | ; Rather than just compilation-top we see (compilation-top zo 0). 269 | ; It simply means that compilation-top has a zo structure as a super type. 270 | ; Note that the zo structure has no fields. 271 | 272 | ; Back to the result of compiling (+ 1 2): 273 | ; (compilation-top0 (prefix 0 '() '()) 3) 274 | ; Where did the +, 1 and 2 go? 275 | ; Well, the compiler determined at compile time that (+ 1 2) gives 3, 276 | ; so the actual bytecode consists of nothing else but the constant 3. 277 | 278 | ;;; Exercise 279 | ; Find a small program which forces the runtime to perform the calcuation (+ 1 2). 280 | ; This attempt failed: 281 | ; > (compile-zo '((lambda (x) (+ 1 x)) 2)) 282 | ; '#s((compilation-top zo 0) 0 #s((prefix zo 0) 0 () ()) 3) 283 | 284 | ; And for completeness sake: 285 | 286 | (define (string->bytecode str [ns (make-start-namespace)]) 287 | (s-exp->bytecode (read (open-input-string str)) ns)) 288 | 289 | (define (string->zo str [ns (make-start-namespace)]) 290 | (bytecode->zo (string->bytecode str ns))) 291 | 292 | ;;; 293 | ;;; SANITY CHECK / CHEATING 294 | ;;; 295 | 296 | ; It is convenient to compare the output of eval-zo with 297 | ; the result of the standard racket evaluator. 298 | ; It will also allow us to convert zo-syntax-objects into real syntax objects. 299 | 300 | (define (racket-eval-zo zo [ns (make-start-namespace)]) 301 | ; note: zo-marshal does not support top-level require 302 | (parameterize ([current-namespace ns] [read-accept-compiled #t]) 303 | (eval 304 | (read 305 | (open-input-bytes 306 | (zo-marshal zo)))))) 307 | 308 | ; this one works too 309 | ; [tell me where the docs say that eval know how to evaluate compiled expressions] 310 | #;(define (racket-eval-zo zo [ns (make-start-namespace)]) 311 | (parameterize ([current-namespace ns]) 312 | (fasl->s-exp 313 | (open-input-bytes 314 | (zo-marshal zo))))) 315 | 316 | ; stx->syntax : stx -> syntax 317 | ; convert a zo representing a syntax-object 318 | ; the conversion was made by imitating the output of (s-exp->zo '#'x)) 319 | (define (stx->syntax stx) 320 | (racket-eval-zo (compilation-top 0 (hash) (prefix 0 '() (list stx) 'some-inspector) 321 | (topsyntax 0 0 0)))) 322 | 323 | ;;; 324 | ;;; LOCAL VARIABLES AND THE STACK REGISTER 325 | ;;; 326 | 327 | ; The Racket virtual machine use a stack to store local variables. 328 | ; Here a mutable list, an mlist, is used. An alternative would 329 | ; be to use lists of boxes. 330 | 331 | (define stack '()) ; a global variable holds the stack. 332 | 333 | ;;; 334 | ;;; MUTABLE LISTS (mlists) 335 | ;;; 336 | 337 | ; A few operations on mutable lists are needed. 338 | ; [ racket/mlist needs some love ] 339 | 340 | (require compatibility/mlist) 341 | (define (make-mlist n [val #f]) 342 | (let loop ([xs '()] [n n]) 343 | (if (zero? n) xs (loop (mcons val xs) (- n 1))))) 344 | (define (mdrop xs n) ; drop n mpairs 345 | (let loop ([xs xs] [n n]) 346 | (if (zero? n) xs (loop (mcdr xs) (- n 1))))) 347 | (define (msplit-at list0 n0) 348 | (let loop ([list list0] [n n0] [pfx '()]) 349 | (cond [(zero? n) (values (mreverse pfx) list)] 350 | [(mpair? list) (loop (mcdr list) (sub1 n) (mcons (mcar list) pfx))] 351 | [else (error 'msplit-at "count too large, got: ~a ~a" list0 n0)]))) 352 | (define (append-vector-to-mlist v xs) 353 | (define n (vector-length v)) 354 | (for/fold ([xs xs]) ([i (in-range (- n 1) -1 -1)]) 355 | (mcons (vector-ref v i) xs))) 356 | ;;; 357 | ;;; Primitives 358 | ;;; 359 | 360 | ; Procedures implemented in the C runtime are called primitives. 361 | ; [As of July 2014 there are 1096 primitives!] 362 | ; In bytecode they are referred to by index (number). 363 | 364 | ; There is no builtin way to access primitives by number, 365 | ; so we construct a little bytecode program, that evaluates 366 | ; to the corresponding primitive. 367 | 368 | ; get-primitive : index -> primitive 369 | (define (get-primitive index) 370 | ; todo: cache these in a vector 371 | (racket-eval-zo (compilation-top 0 (hash) (prefix 0 '() '() 'some-inspector) 372 | (primval index)))) 373 | 374 | ; When reading bytecode it is convenient to see a name instead, 375 | ; so we need a table that maps the index to the name of the primitive. 376 | 377 | ; Introducing new or removing old primitives can change their index, 378 | ; so to avoid changing the table of primitives manually, we do the 379 | ; following: 380 | ; - make a namespace and import all primitives into it 381 | ; by requiring #%kernel, #%unsafe, etc. 382 | ; - for each identifier in the name space, compile a reference to it 383 | ; - see if the result contains (struct primval (n)) 384 | ; - if so the index is n, if not the identifier wasn't bound to a primitive 385 | 386 | ; The result is a table of the form: 387 | ; '#hash((665 . date-time-zone-offset) (794 . exn:fail:contract:divide-by-zero) ...) 388 | 389 | (define primitive-table ; hashtable from index to primitive 390 | (let ([ns (make-base-empty-namespace)]) ; make namespace with racket/base attached 391 | (parameterize ([current-namespace ns]) 392 | (namespace-require ''#%kernel) ; import all primitives 393 | (namespace-require ''#%unsafe) 394 | (namespace-require ''#%flfxnum) 395 | (namespace-require ''#%extfl) 396 | (namespace-require ''#%futures) 397 | (namespace-require ''#%foreign) 398 | ; For each symbol we need to find its index. We do this by compiling a 399 | ; reference to it and picking the index out of the resulting bytecode. 400 | ; Example: The index of namespace-variable-values is 1077. 401 | ; (compile-zo 'namespace-variable-value) 402 | ; '#s((compilation-top zo 0) 0 #s((prefix zo 0) 0 () ()) 403 | ; #s((primval expr 0 form 0 zo 0) 1077)) 404 | ; The index of namespace-variable-value is 1077. 405 | (define (symbol->index sym) 406 | (with-handlers ([exn:fail? (lambda (x) #f)]) 407 | (match (compile-zo sym) 408 | [(struct compilation-top (_ __ prefix (struct primval (n)))) n] 409 | [else #f]))) 410 | ; we will store out results in a hash-table 411 | (define table (make-hash)) 412 | (for/list ([sym (namespace-mapped-symbols)]) 413 | (define index (symbol->index sym)) 414 | (when index (hash-set! table sym index))) 415 | table))) 416 | 417 | ;;; 418 | ;;; Decompilation 419 | ;;; 420 | 421 | ; The module compiler/decompile provides a decompiler from bytecode 422 | ; to readable s-expressions. That can handy at times. 423 | ; See the documentation for the identifier conventions used. 424 | 425 | ; > (use-start) (decompile (compile-zo '(+ x 1))) 426 | ; '(begin (+ (#%checked _x) '1)) 427 | 428 | 429 | ;;; 430 | ;;; XXX 431 | ;;; 432 | 433 | 434 | 435 | ; Top-level and module-level variable are managed in a namespace. 436 | ; A name associates a symbols with buckets (think boxes) which 437 | ; contain the value of the variable. Importing a module 438 | ; does note create new buckets. Importing simply redirects 439 | ; access to the (shared) buckets. 440 | 441 | 442 | 443 | 444 | (define (get-imported id pos modidx) 445 | ; note: (dynamic-require mod id) won't works since id can be a non-exported identifier 446 | (define mod (module-path-index-resolve modidx)) 447 | ; (define exports (call-with-values (λ() (module->exports mod)) vector)) 448 | ; note: (vector-ref exports pos) will give the entry of id 449 | ; The current-namespace has a module registry. 450 | (dynamic-require mod #f) ; Register and instantiate the module mod if not already 451 | ; Look up id in the namespace belonging to mod 452 | (namespace-variable-value id #f (λ () (error)) (module->namespace mod))) 453 | 454 | ; get-imported : 455 | ; get the value of an imported module-variable 456 | ; this is only called by eval-prefix 457 | ; Racket's builtin eval and compile is used to get the value. 458 | ; Note: This low-level version works as well. 459 | 460 | #;(define (get-imported id pos modidx) 461 | (displayln (list 'get-imported id pos (mpi->string modidx))) 462 | (racket-eval-zo 463 | (compilation-top 0 ; max-let-depth 464 | (prefix 0 (list (module-variable modidx id pos 0 #f)) '()) 465 | (toplevel 0 0 #t #t)))) 466 | 467 | 468 | (define (list-ref/protect l pos who) 469 | ; useful for debugging faulty bytecode ... 470 | (list-ref l pos) 471 | #; 472 | (if (pos . < . (length l)) 473 | (list-ref l pos) 474 | `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) 475 | 476 | ;;; 477 | ;;; Decompilation 478 | ;;; 479 | 480 | ; The function zo-parse will parse bytecode and deliver zo-structures 481 | ; representing the bytecode in all detail. The function decompile 482 | ; converts this structure into a human readable s-exp. 483 | 484 | ; The code is written as a recursive descent. To pass along information 485 | ; on globally defined variables, the structure glob-desc is used. 486 | 487 | (define-struct glob-desc (vars num-tls num-stxs num-lifts)) ; explanation follows 488 | ; (num-tls stands for "number of toplevels) 489 | 490 | 491 | ;;; 492 | ;;; EXTRA BYTE CODES 493 | ;;; 494 | 495 | ; We will add two byte codes not present in the real Racket VM here. 496 | ; The first, trace, is for debugging. The second is used to implement modules. 497 | 498 | (define-struct (trace form) (form) #:transparent) 499 | ; Display the stack, then evaluate form. 500 | 501 | (define-struct (module-body form) (prefix forms) #:transparent) 502 | ; Push the prefix to the stack, then evaluate the forms. 503 | 504 | 505 | ;;; 506 | ;;; EVALUATION 507 | ;;; 508 | 509 | ; And finally... here comes the beginning of the evaluator. 510 | 511 | ; The result of compile-zo is a compilation-top, so that's where the 512 | ; decompilation process begins. 513 | 514 | ; (struct compilation-top zo (max-let-depth prefix form) 515 | 516 | ; The compilation-top consists of code (form), which are instructions to run on a stack machine. 517 | ; The max-let-depth is maximum stack depth that code creates (not counting the prefix array). 518 | ; The prefix describes what the runtime must push on the stack before executing code. 519 | 520 | ; Since we have as many mpairs to our disposal as we want, we will ignore max-let-depth. 521 | ; A nice exercise would be to replace the stack representation from mlists to a vector 522 | ; base one. 523 | 524 | ; eval-zo : compilation-top [namespace] -> values(s) 525 | (define (eval-zo zo [ns (make-start-namespace)]) 526 | ; If zo is a zo structure (representing bytecode) evaluate it. 527 | ; If zo is an s-expression, then compile it before evaluating it. 528 | (cond [(zo? zo) (unless (compilation-top? zo) 529 | (error 'eval-zo "expected a compilation-top, got ~a" zo)) 530 | ; evaluation always occur within a top-level namespace 531 | ; if none are given (make-start-namespace) is used 532 | (parameterize ([current-namespace ns]) 533 | (eval-top zo))] 534 | [else (eval-zo (compile-zo zo ns) ns)])) 535 | 536 | ; eval-top : compilation-top -> value(s) 537 | (define (eval-top top) 538 | (match top 539 | [(struct compilation-top (max-let-depth binding-namess prefix form)) ; TODO (binding-namess) 540 | ; the prefix describes an array of variables that must be pushed to the stack ... 541 | (define array (eval-prefix prefix)) 542 | (set! stack (mlist array)) 543 | ; ... before form is evaluated 544 | (eval-form form)] 545 | [else (error 'eval-top "unrecognized: ~e" top)])) 546 | 547 | ;;; 548 | ;;; PREFIX ARRAYS 549 | ;;; 550 | 551 | ; The evaluation in eval-top begins by pushing a prefix array onto the stack. 552 | ; Here a simple vector is used to store the array. 553 | ; But what does the prefix description look like in the bytecode? 554 | 555 | ; (struct prefix zo (num-lifts toplevels stxs) 556 | ; At runtime a prefix is an array holding variables. 557 | ; The array is pushed to the stack to initiate evaluation. 558 | 559 | ; Each slot of the array is called a bucket. 560 | ; The buckets are used in this order: 561 | ; toplevels, stxs, maybe one extra bucket, lifted-local-procedures 562 | ; The extra bucket is only used if stxs is non-empty. 563 | ; The number of buckets used for toplevels are (length toplevels) 564 | ; The number of buckets used for stxs are (length stxs) 565 | ; The number of extra buckets are (if (empty? stxs) 0 1) 566 | ; The number of lifted-local-procedures are num-lifts. 567 | ; The length of the array are thus known. 568 | 569 | ; We will use a mutable list to represent the stack. Local variables will be stored directly 570 | ; into the mcars. 571 | 572 | ; Top level (and imported module) variables (i.e. namespace variables) are stored 573 | ; in the namespace. 574 | ; More precisely they are stored in buckets. When the prefix is initialized 575 | ; the bucket of a global variable are put into the prefix. 576 | ; That is: import does not create new top-level variables ! 577 | ; Importing variables from a module will redirect access to the (shared) buckets. 578 | 579 | ; In the interpreter we use a standard racket namespace to represent top-level variables, 580 | ; but we use our own prefix representation. This implies that using the standard Racket 581 | ; require to import modules, will store the imported variables 582 | ; in the prefix of the Racket vm - and but not in our prefix. 583 | 584 | ; We can't get to the buckets (??? or can we via the FFI ???) so we store 585 | ; an instance of (struct global (sym)) in our prefix array. At variable lookup time 586 | ; a lookup of a global, will use namespace-variable-value to get the value from the namespace. 587 | ; See array-ref and array-set and the req section of eval-for for more information. 588 | 589 | (struct global (sym ns) #:transparent) 590 | (define (create-global sym) (global sym (current-namespace))) 591 | 592 | ; get-array : natrual -> vector 593 | ; get the prefix array stored in stack at the given depth 594 | (define (get-array depth) 595 | (mcar (mdrop stack depth))) 596 | 597 | ; array-ref : depth pos -> value 598 | ; Get the value with position pos (index into the array) 599 | ; in the prefix stored at the stack in the given depth. 600 | ; A reference to a top-level variable will be redirected 601 | ; to the actual bucket. 602 | (define (array-ref depth pos) 603 | ; (displayln (list 'array-ref 'phase: (current-phase) depth pos (get-array depth))) 604 | (define val (vector-ref (get-array depth) pos)) 605 | (match val 606 | [(global sym ns) 607 | ; Global variables are stored directly in the namespace. 608 | ; in order to work with require, which imports into the real racket prefix 609 | (define p (current-phase)) 610 | (if (= p 0) 611 | (namespace-variable-value sym #t (λ () 'undefined-global) ns) ; fast path 612 | (namespace-variable-value-in-phase sym p ns))] 613 | [else val])) 614 | 615 | ; array-set! : natural natural value -> void 616 | ; set the variable at the given depth and position 617 | ; assignments to top-level variables are redirected 618 | (define (array-set! depth pos val) 619 | ; In principle a simple vector-set!, but we need to redirect assignments 620 | ; to global variables, which are stored in Racket's buckets. 621 | ; The only complication is that there are different buckets for each phase 622 | ; and namespace-set-variable-value! only supports phase 0. 623 | (define array (get-array depth)) 624 | (define old-val (vector-ref array pos)) 625 | (match old-val 626 | [(global sym ns) (define p (current-phase)) 627 | (if (= p 0) 628 | (namespace-set-variable-value! sym val #t ns) ; fast path 629 | (namespace-set-variable-value-in-phase! sym val p ns))] 630 | [else (vector-set! array pos val)])) 631 | 632 | ; namespace-variable-value-in-phase : symbol nonnegative-integer -> value 633 | ; in phase p get value of x 634 | (define (namespace-variable-value-in-phase x p ns) 635 | ; (displayln (list 'namespace-variable-value-in-phase x p ns)) 636 | (unless (and (integer? p) (not (negative? p))) (error)) 637 | (define (on-fail) ') 638 | (parameterize ([current-namespace ns]) 639 | (eval (wrap-expr-for-meta p `(namespace-variable-value ',x #t ,on-fail))))) 640 | 641 | ; namespace-set-variable-value-in-phase! : sym value nonnegative-integer -> void 642 | ; in phase p set value of x to v 643 | (define (namespace-set-variable-value-in-phase! x v p ns) 644 | ; (displayln (list 'namespace-set-variable-value-in-phase! x v p ns)) 645 | (unless (and (integer? p) (not (negative? p))) (error)) 646 | (define (build p e) (if (= p 0) e (build (- p 1) `(begin-for-syntax ,e)))) 647 | (parameterize ([current-namespace ns]) 648 | (eval (wrap-begin-for-meta p `(namespace-set-variable-value! ',x ,v #t))))) 649 | 650 | ; wrap-for-meta : (phase expr -> expr) phase expr 651 | ; wrap the expression e p times using wrapper 652 | (define (wrap-for-meta wrapper p e) 653 | (for/fold ([e e]) ([_ (in-range p)]) 654 | (wrapper e))) 655 | 656 | ; wrap-begin-for-syntax : s-exp -> s-exp 657 | (define (wrap-begin-for-syntax e) 658 | `(begin-for-syntax ,e)) 659 | 660 | (define (wrap-begin-for-meta p e) 661 | ; no begin-for-meta in racket (?!) 662 | (wrap-for-meta wrap-begin-for-syntax p e)) 663 | 664 | (define (wrap-expr-for-syntax x) 665 | ; assume x evaluates to a single value 666 | `(let-syntax ([ref (λ(_) #`#,,x)]) (ref))) 667 | 668 | (define (wrap-expr-for-meta p x) 669 | (wrap-for-meta wrap-expr-for-syntax p x)) 670 | 671 | ;;; 672 | ;;; PREFIX EVALUATION 673 | ;;; 674 | 675 | ; eval-prefix : prefix -> vector 676 | (define (eval-prefix a-prefix) 677 | (match a-prefix 678 | [(struct prefix (num-lifts toplevels stxs src-inspector-desc)) ; TODO (src-inspector-desc) 679 | ; allocate array 680 | (define size (+ (length toplevels) (length stxs) (if (null? stxs) 0 1) num-lifts)) 681 | (define array (make-vector size #f)) ; could use undefined here (but #f prints smaller) 682 | ; fill in values for toplevel and imported variables 683 | (for ([i (in-naturals)] [tl (in-list toplevels)]) 684 | (vector-set! 685 | array i 686 | (match tl 687 | ; #f represents a dummy variable used to access the enclosing module 688 | ; [Comment in docs for seq-for-syntaxes hits that this should be (current-namespace)?] 689 | [#f '#%linkage] ; todo: should that be array instead ? 690 | ; top-level variables (outside of modules) are accessed through the current namespace 691 | [(struct global-bucket (name)) 692 | ; (displayln (list 'eval-prefix 'global-bucket name)) 693 | (create-global name)] 694 | [(? symbol? s) ; a symbol is a reference to a variable defined in an enclosing module 695 | ; (displayln (list 'prefix 'symbol: s)) 696 | (create-global s)] 697 | ; variable imported from module 698 | [(struct module-variable (modidx sym pos phase constantness)) 699 | ; (displayln (list 'module-variable modidx sym pos phase constantness)) 700 | ; (displayln (mpi->string modidx)) 701 | (if (and (module-path-index? modidx) 702 | (let-values ([(n b) (module-path-index-split modidx)]) 703 | (and (not n) (not b)))) ; n = b = #f represents "self module" 704 | ; exercise: find a program that gets here ... 705 | (error 'todo: 'maybe: (vector-ref array pos)) ; identifier from this module 706 | (get-imported sym pos modidx))] ; imported identifier 707 | [else (error 'decompile-prefix "bad toplevel: ~e" tl)]))) 708 | ; fill in syntax-objects from stxs 709 | (for ([i (in-naturals (length toplevels))] [stx (in-list stxs)]) 710 | (vector-set! array i (stx->syntax stx))) 711 | array])) 712 | 713 | ; mpi : module-path-index->string 714 | ; unused (a leftover from the decompiler) 715 | (define (mpi->string modidx) 716 | (cond [(symbol? modidx) modidx] 717 | [else (collapse-module-path-index 718 | modidx (build-path (or (current-load-relative-directory) (current-directory)) 719 | "here.rkt"))])) 720 | 721 | ;;; 722 | ;;; EVALUATION OF FORMS 723 | ;;; 724 | 725 | ; (struct form zo ()) 726 | ; Form is the super-type for all form that can appear in compiled code 727 | ; except for literals that are represented as themselves. 728 | 729 | (define (eval-forms forms) 730 | (match forms 731 | [(list) (void)] 732 | [(list form) (eval-form form)] 733 | [(list form forms) (eval-form form) 734 | (eval-forms forms)] 735 | [_ (eval-expr forms)])) 736 | 737 | (define current-phase (make-parameter 0)) 738 | 739 | (define (eval-form form) 740 | (when trace-on (displayln form)) 741 | (match form 742 | [(? expr? e) (eval-expr e)] 743 | [(struct seq (forms)) 744 | ; evaluate forms in sequence, the last form is in tail position 745 | (let loop ([forms forms]) 746 | (cond [(null? forms) (error 'seq "empty seq")] 747 | [(null? (rest forms)) (eval-form (car forms))] 748 | [else (eval-form (car forms)) 749 | (loop (rest forms))]))] 750 | [(struct splice (forms)) 751 | ; Represents a top-level begin form where each evaluation is wrapped with a continuation prompt. 752 | (let loop ([forms forms]) 753 | (cond [(null? forms) (error 'seq "empty seq")] 754 | [(null? (rest forms)) (call-with-continuation-prompt (λ() (eval-form (car forms))))] 755 | [else (call-with-continuation-prompt (λ() (eval-form (car forms)))) 756 | (loop (rest forms))]))] 757 | [(struct def-values (ids rhs)) 758 | ; Each id is a toplevel: (struct toplevel expr (depth pos const? ready?)) 759 | ; A toplevel represents a reference to a top-level or imported variable via the prefix array. 760 | ; The depth field indicates the number of stack slots to skip to reach the prefix array, 761 | ; and pos is the offset into the array. 762 | (define old-stack stack) 763 | (define vals (call-with-values (λ () (eval-form rhs)) vector)) 764 | (set! stack old-stack) 765 | (for ([id (in-list ids)] [v (in-vector vals)]) 766 | (match-define (toplevel depth pos const? ready?) id) 767 | (array-set! depth pos v))] 768 | [(struct seq-for-syntax (forms prefix max-let-depth dummy)) 769 | ; From the docs on begin-for-syntax: 770 | ; Evaluation of an expr within begin-for-syntax is parameterized to 771 | ; set current-namespace as in let-syntax. 772 | ; From the docs on (let-syntax ([id trans-expr] ...) body ...+) 773 | ; The evaluation of each trans-expr is parameterized to set current-namespace to a 774 | ; namespace that shares bindings and variables with the namespace being used to 775 | ; expand the let-syntax form, except that its base phase is one greater. 776 | (define old-stack stack) 777 | ; push prefix 778 | (define array (eval-prefix prefix)) 779 | (set! stack (mcons array stack)) 780 | ; evaluate forms in sequence, the last form is in tail position (?) 781 | (define p (current-phase)) 782 | (parameterize ([current-phase (+ p 1)]) 783 | ; let-syntaxes shifts the phase, 784 | ; and (eval `(,eval- ...)) returns control to the meta evaluator. 785 | (let-syntaxes () (eval `(,eval-forms ',forms)) (values))) 786 | (set! stack old-stack)] 787 | [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) 788 | (define old-stack stack) 789 | ; push prefix 790 | (define array (eval-prefix prefix)) 791 | (set! stack (mcons array stack)) 792 | ; in phase p+1 evaluate forms in sequence (the last form is in tail position (?)) 793 | (define p+1 (+ (current-phase) 1)) 794 | (define returned-values #f) 795 | (define (return vec) (set! returned-values vec)) 796 | (parameterize ([current-phase p+1]) 797 | ; (define vals (call-with-values (λ () (eval-form rhs)) vector)) 798 | (let-syntaxes ; shift phasae 799 | () (eval `(,return ; store in returned-values 800 | (call-with-values 801 | (λ () `(,,eval-forms ',,rhs)) ; the result of evaluting rhs 802 | vector))) 803 | (values))) 804 | ; restore stack 805 | (set! stack old-stack) 806 | ; install values in the namespace 807 | (define ns (current-namespace)) 808 | (for ([sym (in-list ids)] [val (in-vector returned-values)]) 809 | (namespace-set-variable-value-in-phase! sym val p+1 ns))] 810 | [(struct req (reqs dummy)) 811 | ; (displayln (list 'req (stx->syntax reqs))) 812 | ; This is the top-level #%require form. 813 | ; The syntax object reqs represents a (#%require raw-require-spec ...) form. 814 | ; It is the primitive import form to which require expands. 815 | (define #%require-form (stx->syntax reqs)) 816 | ; Register module in namespace, instantiate it and import variables into 817 | ; the prefix the racket runtime uses. 818 | (eval (syntax->datum #%require-form)) ; XXX TODO okay to strip ? 819 | ; Using (eval '(require mod)) imports mod into the current namespace. 820 | ; Since we are using the namespace to store top-level variables 821 | ; we get access to module imported variables. 822 | ] 823 | [(? mod? mod-form) ; declares a module, delegate to eval-module 824 | (eval-module mod-form)] 825 | [(module-body prefix forms) ; not in the real Racket VM 826 | (define old-stack stack) 827 | ; push prefix 828 | (define array (eval-prefix prefix)) 829 | (set! stack (mcons array stack)) 830 | ; evaluate forms 831 | (for ([form (in-list forms)]) 832 | (eval-form form)) 833 | ; pop prefix 834 | (set! stack old-stack)] 835 | ; trace is useful for debugging 836 | [(trace form) (displayln (list 'trace stack)) (eval-form form)] 837 | [else ; literals are expressions too 838 | (eval-expr form)])) 839 | 840 | ;;; 841 | ;;; EVALUATION OF EXPRESSIONS 842 | ;;; 843 | 844 | ; The main evaluator of expressions are eval-expr. 845 | ; The pattern: save stack, evaluate expression, restore stack 846 | ; occurs so often that it is convenient to have eval-expr/restore 847 | ; and eval-ecpr/restore-mv. The last can handle multiple values. 848 | 849 | (define (eval-expr/restore expr) 850 | (define old-stack stack) 851 | (define val (eval-expr expr)) 852 | (set! stack old-stack) 853 | val) 854 | 855 | (define (eval-expr/restore-mv expr) 856 | (define old-stack stack) 857 | (define vals (call-with-values (λ () (eval-form expr)) vector)) 858 | (set! stack old-stack) 859 | vals) 860 | 861 | (define trace-on #f) (set! trace-on #f) 862 | (define (eval-expr expr) 863 | (when trace-on (displayln expr) (newline)) 864 | (match expr 865 | [(struct toplevel (depth pos const? ready?)) 866 | ; Represents a reference to a top-level or imported variable via the prefix array. 867 | ; The depth field indicates the number of stack slots to skip to reach the prefix array, 868 | ; and pos is the offset into the array. 869 | (array-ref depth pos)] 870 | [(struct topsyntax (depth pos midpt)) 871 | ; Represents a reference to a quoted syntax object via the prefix array. 872 | (array-ref depth (+ midpt pos))] 873 | [(struct primval (id)) 874 | ; Represents a direct reference to a variable imported from the run-time kernel. 875 | (get-primitive id)] 876 | [(struct assign (id rhs undef-ok?)) 877 | ; Represents a set! expression that assigns to a top-level or module-level variable 878 | ; through an array installed by a prefix. 879 | ; (Assignments to local variables are represented by install-value expressions.) 880 | ; After rhs is evaluated, the stack is restored to its depth from before evaluating rhs. 881 | (match-define (toplevel depth pos const? ready?) id) 882 | (unless undef-ok? ; see compile-allow-set!-undefined in s-exp->zo 883 | (define old-val (array-ref depth pos)) 884 | (when (eq? old-val undefined) 885 | ; TODO: figure out how to find the name of the offending variable 886 | (error 'set! "assignment disallowed;\n cannot set undefined\n variable: XXX"))) 887 | (define val (eval-expr/restore rhs)) 888 | (array-set! depth pos val)] 889 | [(struct localref (unbox? offset clear? other-clears? type)) 890 | (define v (mlist-ref stack offset)) ; todo: handle clear? (to ensure safe-for-space) 891 | (define val (if unbox? (unbox v) v)) 892 | (when (eq? val 'undef) 893 | (newline) 894 | (displayln (list 'local-ref "reference to undef" offset stack)) 895 | (newline) (newline)) 896 | val] 897 | [(? lam? lam) (eval-lam lam)] ; lambda expression 898 | [(struct case-lam (name lams)) 899 | ; Represents a case-lambda form as a combination of lambda forms that are tried (in order) 900 | ; based on the number of arguments given. 901 | ; Strategy: compile case-lam into a case-clos 902 | ; case-clos has a vector of arities and a a vector of clos 903 | ; the arity-vector is used at application time to decide with clos to use 904 | ; arities with rest arguments are represented as negative values 905 | ; arity = -1 means 0 or more, arity = -2 means 1 or more, etc 906 | (define clos-vector (for/vector ([lam (in-list lams)]) 907 | (eval-lam lam))) 908 | (define arities (for/vector ([lam (in-list lams)]) 909 | (define n (lam-num-params lam)) 910 | (define r? (lam-rest? lam)) 911 | (if r? (- (+ n 1)) n))) 912 | (case-clos name arities clos-vector)] 913 | [(struct let-one (rhs body type unused?)) 914 | ; Pushes an uninitialized slot onto the stack, evaluates rhs and 915 | ; puts its value into the slot, and then runs body. 916 | ; After rhs is evaluated, the stack is restored to its depth from before evaluating rhs. 917 | (set! stack (mcons #f stack)) 918 | (define val (eval-expr/restore rhs)) 919 | ; no stack restore! 920 | (set-mcar! stack val) 921 | (eval-expr body)] 922 | [(struct let-void (count boxes? body)) 923 | ; Pushes count uninitialized slots onto the stack and then runs body. 924 | ; If boxes? is #t, then the slots are filled with boxes that contain #. 925 | (let loop ([new-stack stack] [n count]) 926 | (cond [(zero? n) (set! stack new-stack) 927 | (eval-expr body)] 928 | [boxes? (loop (mcons (box 'undef) new-stack) (- n 1))] 929 | [else (loop (mcons 'undef new-stack) (- n 1))]))] 930 | [(struct let-rec (lams body)) 931 | ; Represents a letrec form with lambda bindings: 932 | ; (letrec ([id (lambda ...)] ...) body) 933 | ; It allocates a closure shell for each lambda form in procs, 934 | ; installs each onto the stack in previously allocated slots in reverse order 935 | ; (so that the closure shell for the last element of procs is installed at stack position 0), 936 | ; fills out each shell’s closure (where each closure normally references some other 937 | ; just-created closures, which is possible because the shells have been installed on the stack), 938 | ; and then evaluates body. 939 | 940 | ; Note: The closure shells can not be omitted. If the first lambda captures the second 941 | ; it will capture the value on the stack - which is undef! 942 | ; Therefore: Install shells first - then the shell is captured. 943 | ; Second fill in the shells. 944 | ; install shells 945 | (let loop ([lams lams] [s stack]) 946 | (cond [(null? lams) (void)] 947 | [else (set-mcar! s (shell #f)) 948 | (loop (cdr lams) (mcdr s))])) 949 | ; fill in lambdas 950 | (let loop ([lams lams] [s stack]) 951 | (cond [(null? lams) (void)] 952 | [else (define shell (mcar s)) 953 | (define clos (eval-lam (first lams))) ; alloc-lam (no stack save here) 954 | (set-shell-closure! shell clos) 955 | (loop (cdr lams) (mcdr s))])) 956 | ; evaluate body 957 | (eval-expr body)] 958 | [(struct install-value (count pos boxes? rhs body)) 959 | ; evaluate the rhs and push the result value(s) 960 | ; into previously allocated slots on the stack 961 | ; (displayln (list 'install-value count stack)) 962 | (cond [(= count 1) ; rhs returns 1 value 963 | (define val (eval-expr/restore rhs)) 964 | (define slot (mdrop stack pos)) 965 | (if boxes? 966 | (set-box! (mcar slot) val) 967 | (set-mcar! slot val))] 968 | [else ; rhs returns multiple values 969 | (define vals (eval-expr/restore-mv rhs)) 970 | (let loop ([slot (mdrop stack pos)] [count count] [i 0]) 971 | (cond [(= count 0) (void)] 972 | [else (define val (vector-ref vals i)) 973 | (if boxes? 974 | (set-box! (mcar slot) val) 975 | (set-mcar! slot val)) 976 | (loop (mcdr slot) (- count 1) (+ i 1))]))]) 977 | (eval-expr body)] 978 | [(struct boxenv (pos body)) 979 | ; (displayln (list 'boxenv pos stack)) 980 | (define s (mdrop stack pos)) 981 | (set-mcar! s (box (mcar s))) 982 | (eval-expr body)] 983 | [(struct branch (test then else)) 984 | (define val (eval-expr/restore test)) 985 | (if val 986 | (eval-expr then) 987 | (eval-expr else))] 988 | [(struct application (rator rands)) 989 | ; Represents a function call. The rator field is the expression for the function, 990 | ; and rands are the argument expressions. 991 | ; Before any of the expressions are evaluated, (length rands) uninitialized stack slots 992 | ; are created (to be used as temporary space). 993 | (define new-slots (make-mlist (length rands) ')) 994 | (define old-stack stack) 995 | (set! stack (mappend new-slots stack)) ; todo: make efficient 996 | (define op (eval-expr/restore rator)) 997 | (define args (for/list ([rand (in-list rands)]) 998 | (eval-expr/restore rand))) 999 | (let loop ([op op]) 1000 | (cond 1001 | [(clos? op) (invoke-clos rator rands op args old-stack)] 1002 | [(case-clos? op) (invoke-case-clos rator rands op args old-stack)] 1003 | [(shell? op) (loop (shell-closure op))] 1004 | [(or (primitive? op) 1005 | (continuation? op) 1006 | (procedure? op)) 1007 | ; builtin types of procedures 1008 | (begin0 1009 | (apply op args) 1010 | (set! stack (mdrop stack (length args))))] 1011 | [else 1012 | (displayln (list 'application-error op args stack)) 1013 | (error 'app "can't apply ~a" op)]))] 1014 | [(struct apply-values (proc args-expr)) 1015 | ; Represents (call-with-values (lambda () args-expr) proc). 1016 | ; Note: due to left-to-right evaluation, proc is evaluated first 1017 | (define old-stack stack) 1018 | (define op (eval-expr proc)) 1019 | (define receiver (if (or (primitive? op) (procedure? op)) list mlist)) 1020 | (define args (call-with-values (λ () (eval-expr args-expr)) receiver)) 1021 | ; todo: use invoke-clos instead (for prettier code) 1022 | (define (handle-clos op) 1023 | (match-define (clos name num-params rest? captures body) op) 1024 | ; When the function is called, the rest-argument list (if any) is pushed onto the stack, 1025 | ; then the normal arguments in reverse order, then the closure-captured values in 1026 | ; reverse order. Thus, when body is run, the first value on the stack is the first value 1027 | ; captured by the closure-map array, and so on. 1028 | (define n (mlength args)) 1029 | (cond [(= n num-params) 1030 | ; we didn't bang the operands into the new slots, so we do this (TODO) 1031 | (set! stack (append-vector-to-mlist captures (mappend args stack))) 1032 | (eval-expr body)] 1033 | [(and (> n num-params) rest?) 1034 | (define-values (mnormal mrest) (msplit-at args num-params)) 1035 | (define rest (mlist->list mrest)) ; rest is a list (used with standard apply) 1036 | (set! stack (append-vector-to-mlist captures (mappend mnormal (mcons rest stack)))) 1037 | (eval-expr body)] 1038 | [(> n num-params) 1039 | (error 'app "too many argument applying ~a to ~a" op args)] 1040 | [(< n num-params) 1041 | (error 'app "too few argument in application\n closure: ~a\n\n arguments: ~a" 1042 | op args)])) 1043 | (let loop ([op op]) 1044 | (cond 1045 | [(primitive? op) (apply op args)] 1046 | [(procedure? op) (apply op args)] ; imports 1047 | [(clos? op) (handle-clos op)] 1048 | [(case-clos? op) (define n (mlength args)) 1049 | (match-define (case-clos name arities clos-vector) op) 1050 | ; find the first index for a matching arity 1051 | (define idx (for/or ([a (in-vector arities)] [i (in-naturals)]) 1052 | (and (or (and (positive? a) (= a n)) 1053 | (and (negative? a) (>= n (- (- a) 1)))) 1054 | i))) 1055 | (unless idx (error 'application-of-case-clos "no arities match, got ~a" expr)) 1056 | ; apply the corresponding clos 1057 | (handle-clos (vector-ref clos-vector idx))] 1058 | [(shell? op) (loop (shell-closure op))] 1059 | [else (error 'call-with-values "can't apply ~a" op)]))] 1060 | [(struct seq (exprs)) 1061 | (let loop ([exprs exprs]) 1062 | (cond [(null? exprs) (error 'seq "empty seq")] 1063 | [(null? (rest exprs)) (eval-expr (first exprs))] 1064 | [else (eval-expr (first exprs)) 1065 | (loop (rest exprs))]))] 1066 | [(struct beg0 (exprs)) 1067 | (match exprs 1068 | [(list) (error "beg0: empty form not allowed")] 1069 | [(list expr) (eval-expr (first exprs))] ; tail position 1070 | [_ (define result (eval-expr/restore (first exprs))) 1071 | (for ([expr (in-list (rest exprs))]) 1072 | (eval-expr/restore expr)) 1073 | result])] 1074 | [(struct with-cont-mark (key val body)) 1075 | (define k (eval-expr/restore key)) 1076 | (define v (eval-expr/restore val)) 1077 | (with-continuation-mark k v (eval-expr body))] 1078 | [(struct closure (lam gen-id)) 1079 | ; A lambda form with an empty closure, which is a procedure constant. 1080 | ; (No optimization here, we just allocate a standard closure) 1081 | (eval-expr lam)] 1082 | [(struct varref (tl dummy)) 1083 | (error)] ; no #%variable-reference for you 1084 | [else expr])) ; literals evaluate to themselves 1085 | 1086 | ;;; 1087 | ;;; CLOSURES 1088 | ;;; 1089 | 1090 | ; A closure from a lambda expression is represented as a clos structure. 1091 | ; A closure from a case-lambda expression is represented as a case-clos structure. 1092 | 1093 | (struct clos (name num-params rest? captures body) ; represents a closure at runtime 1094 | ; captures = vector of captured values 1095 | ; body = code to run in form of zo-form 1096 | #:transparent 1097 | #:property prop:procedure 1098 | ; In most cases we the closure will be applied in eval-expr throuh 1099 | ; the application bytecode. However if call builtin higher order functions 1100 | ; such as map and apply we need to tell the system to invoke a closure through invoke-clos. 1101 | (λ (op . args) 1102 | ; the args received were on the real racket stack, but invoke-clos expects 1103 | ; there to (length args) slots on the simulated stack 1104 | (define old-stack stack) 1105 | (define new-slots (make-mlist (length args) ')) 1106 | (set! stack (mappend new-slots stack)) 1107 | (invoke-clos ' ' op args old-stack))) 1108 | 1109 | (struct case-clos (name arities clos-vector) 1110 | ; represents a closure of a case-lambda 1111 | ; clos-vector = vector of clos 1112 | ; arities = vector of accepted arities 1113 | ; The accepted arities are encoded as follows: 1114 | ; ... 1115 | ; 1 => exactly 1 1116 | ; 0 => exactly 0 1117 | ; -1 => 0 or more 1118 | ; -2 => 1 or more 1119 | ; ... 1120 | ; See how invoke-case-clos structs are invoked in invoke-case-clos. 1121 | #:transparent 1122 | #:property prop:procedure 1123 | ; Tell system to use invoke-case-clos to invoke closure from case-lambda expressions. 1124 | (λ (op . args) 1125 | ; the args received were on the real racket stack, but invoke-clos expects 1126 | ; there to (length args) slots on the simulated stack 1127 | (define old-stack stack) 1128 | (define new-slots (make-mlist (length args) ')) 1129 | (set! stack (mappend new-slots stack)) 1130 | (invoke-case-clos ' ' op args old-stack))) 1131 | 1132 | 1133 | (struct shell (closure) #:transparent #:mutable 1134 | #:property prop:procedure 1135 | ; Tell the system how to invoke let-rec allocated closures 1136 | (λ (op . args) 1137 | ; Remove shell and invoke contents 1138 | (apply (shell-closure op) args))) 1139 | 1140 | (define (invoke-clos rator rands ; original operator and operands (zo-structs) for debug 1141 | op args ; results of evaluating rator and rands (args is a list) 1142 | old-stack) ; stack before application 1143 | ; apply a clos 1144 | (match-define (clos name num-params rest? captures body) op) 1145 | ; When the function is called, the rest-argument list (if any) is pushed onto the stack, 1146 | ; then the normal arguments in reverse order, then the closure-captured values in 1147 | ; reverse order. Thus, when body is run, the first value on the stack is the first value 1148 | ; captured by the closure-map array, and so on. 1149 | (define n (length args)) 1150 | (cond [(= n num-params) 1151 | ; we didn't bang the operands into the new slots, so we do this (TODO) 1152 | (define margs (list->mlist args)) 1153 | (set! stack (mdrop stack n)) 1154 | (set! stack (append-vector-to-mlist captures (mappend margs stack))) 1155 | (eval-expr body)] 1156 | [(and (> n num-params) rest?) 1157 | (define-values (normal-args rest) (split-at args num-params)) 1158 | ; rest arguments must be a standard list 1159 | (define mnormal-args (list->mlist normal-args)) 1160 | (set! stack (append-vector-to-mlist captures 1161 | (mappend mnormal-args (mcons rest old-stack)))) 1162 | (eval-expr body)] 1163 | [(> n num-params) 1164 | (error 'app "too many argument applying ~a to ~a" op args)] 1165 | [(< n num-params) 1166 | (error 'app "too few argument in application\n closure: ~a\n\n arguments: ~a" 1167 | op args)])) 1168 | 1169 | (define (invoke-case-clos rator rands ; original operator and operands (zo-structs) 1170 | op args ; results of evaluating rator and rands (args is a list) 1171 | old-stack) ; stack before application 1172 | (define n (length args)) 1173 | (match-define (case-clos name arities clos-vector) op) 1174 | ; find the first index for a matching arity 1175 | (define idx (for/or ([a (in-vector arities)] [i (in-naturals)]) 1176 | (and (or (and (positive? a) (= a n)) 1177 | (and (negative? a) (>= n (- (- a) 1)))) 1178 | i))) 1179 | (unless idx (error 'application-of-case-clos "no arities match, got ~a" expr)) 1180 | ; apply the corresponding clos 1181 | (define clos (vector-ref clos-vector idx)) 1182 | (invoke-clos rator rands clos args old-stack)) 1183 | 1184 | (define (eval-lam expr) 1185 | (match expr 1186 | [(struct lam (name ; for debugging purposes 1187 | flags ; 'preserves-marks 'is-method 'single-result 1188 | ; 'only-rest-arg-not-used 'sfs-clear-rest-args 1189 | num-params ; number of arguments accepted by the procedure, 1190 | ; ; not counting a rest argument 1191 | arg-types ; (listof (or/c 'val 'ref 'flonum 'fixnum 'extflonum)) 1192 | ; ; 'val = normal argument, 'ref = boxed 1193 | rest? ; are rest arguments accepted? if so they are 1194 | ; ; collected into a "rest" variable 1195 | closure-map ; vector of stack-positions captured when lambda is evaluated 1196 | closure-types ; types corresponding to the captured variables 1197 | tl-map ; indicates which toplevel variables actually used 1198 | max-let-depth ; indicates the maximum stack depth created by body plus 1199 | ; ; the arguments and closure-captured values pushed onto the stack 1200 | body)) ; expr 1201 | (define captures (make-vector (vector-length closure-map) #f)) 1202 | (for ([i (in-naturals)] [pos (in-vector closure-map)]) 1203 | ; (displayln (list 'eval-lam "capturing " i " " (mlist-ref stack pos))) 1204 | (vector-set! captures i (mlist-ref stack pos))) 1205 | (clos name num-params rest? captures body)])) 1206 | 1207 | ;;; 1208 | ;;; MODULES 1209 | ;;; 1210 | 1211 | ; (struct mod (name srcname ...)) 1212 | ; Represents a module declaration. 1213 | 1214 | ;> (decompile (string->zo "(module foo racket (+ 1 2))")) 1215 | ;'(begin 1216 | ; (module foo .... 1217 | ; (require (lib "racket/main.rkt")) 1218 | ; (module configure-runtime .... 1219 | ; (require '#%kernel (lib "racket/runtime-config.rkt")) 1220 | ; (|_configure:p@(lib "racket/runtime-config.rkt")| '#f)) 1221 | ; (#%apply-values |_print-values:p@(lib "racket/private/modbeg.rkt")| '3))) 1222 | 1223 | #;(eval (let ([zo (s-exp->zo '(begin (define x 42) x))]) 1224 | `(module m racket/base 1225 | (provide x) 1226 | (define x #f) 1227 | (set! x 42) 1228 | ; the evaluation happens inside the module name space 1229 | ; (variable-reference->namespace (#%variable-reference)) 1230 | ; evaluates to the namespace "inside" the module 1231 | (parameterize ([current-namespace (variable-reference->namespace (#%variable-reference))]) 1232 | (,eval-zo ,zo))))) 1233 | 1234 | (define (eval-module mod-form) 1235 | (match mod-form 1236 | [(struct mod 1237 | (name ; symbol => module name 1238 | ; ; list of symbols => submodule , '(foo bar) is submodule bar inside foo 1239 | srcname ; symbol e.g. bar for the submodule bar in foo 1240 | self-modidx ; the module path index 1241 | prefix ; a prefix pushed before evaluation of the body 1242 | provides ; association list from phases to exports 1243 | requires ; association list from phases to imports 1244 | body ; code for phase 0 1245 | syntax-bodies ; syntax-bodies use their own prefix 1246 | unexported ; list of lists of symbols, for unexported definitions 1247 | ; ; these can be accessed during macro expansion 1248 | max-let-depth ; max stack depth created by body forms (not counting prefix) 1249 | dummy ; access to the top-level namespace 1250 | lang-info ; optional module-path for info (used by module->lang-info) 1251 | internal-context ; internal-module-context lexical context of the body 1252 | ; ; #t #f stx or vector of stx 1253 | binding-names ; TODO new 1254 | flags ; list of symbols, there 'cross-phase indicates the module-body 1255 | ; ; is evaluated once and results shared across all phases 1256 | pre-submodules ; module declared submodules 1257 | post-submodules ; module* declared submodules 1258 | )) 1259 | (define (provided->provide-spec phase p) 1260 | (match p 1261 | ;(provided sym mpi/#f sym mpi/#f N boolean?] 1262 | [(provided name src src-name nom-src src-phase protected?) 1263 | (case phase 1264 | [(0) name] 1265 | [(1) `(for-syntax ,name)] 1266 | [(#f) `(for-label ,name)] 1267 | [else `(for-meta ,phase ,name)])])) 1268 | (define (provides->provide-form provides) 1269 | `(provide 1270 | ,@(append* 1271 | (for/list ([a (in-list provides)]) 1272 | (match-define (list phase vars syntaxs) a) 1273 | (append 1274 | (for/list ([p (in-list vars)]) (provided->provide-spec phase p)) 1275 | (for/list ([p (in-list syntaxs)]) (provided->provide-spec (+ phase 1) p))))))) 1276 | (define (provides->var-declarations provides) 1277 | (append* 1278 | (append* 1279 | (for/list ([a (in-list provides)]) 1280 | (match-define (list phase vars syntaxs) a) 1281 | (define vs (map provided-name vars)) 1282 | (case phase 1283 | [(0) `((define-values ,vs (values ,@(for/list ([v vs]) ''undef-decl))))] 1284 | [else '()]))))) 1285 | 1286 | ; (displayln (list 'eval-module provides)) 1287 | ; (displayln (list 'eval-module (provides->provide-form provides))) 1288 | ; (displayln (list 'eval-module (provides->var-declarations provides))) 1289 | 1290 | ; provides = ((0 (#s((provided zo 0) x #f x #f 0 #f)) ()) ; phase 0 1291 | ; (1 () ()) ; phase 1 1292 | ; (#f () ()))) ; phase label 1293 | ; association list (phase ) 1294 | ; (error) 1295 | (define mod-sexp 1296 | `(module ,srcname racket/base ; keep racket/base for now 1297 | ,(provides->provide-form provides) 1298 | ,(provides->var-declarations provides) 1299 | ; the evaluation happens inside the module name space 1300 | ; (variable-reference->namespace (#%variable-reference)) 1301 | ; evaluates to the namespace "inside" the module 1302 | (displayln ,(~a "instantiating module: " srcname)) 1303 | (parameterize ([current-namespace (variable-reference->namespace (#%variable-reference))] 1304 | [compile-allow-set!-undefined #t]) 1305 | ; evaluate body 1306 | (,eval-form ,(trace (module-body prefix body)))))) 1307 | ; (write (list 'module: mod-sexp)) (newline) 1308 | (parameterize (#;[current-module-declare-name (make-resolved-module-path srcname)] 1309 | [compile-enforce-module-constants #f] 1310 | #;[compile-allow-set!-undefined #t]) 1311 | (eval mod-sexp))] 1312 | [else (error 'decompile-module "huh?: ~e" mod-form)])) 1313 | 1314 | ;;; 1315 | ;;; TESTS 1316 | ;;; 1317 | ;; ---------------------------------------- 1318 | (define verbose displayln) 1319 | (require rackunit) 1320 | (verbose "Running test programs") 1321 | 1322 | (verbose "program1") 1323 | (define program1 (string->zo (~a 42))) ; literal 1324 | (check-equal? (eval-zo program1) 42) 1325 | 1326 | (define program2 (string->zo (~a 'time-apply))) ; primval 1327 | (check-equal? (eval-zo program2) time-apply) 1328 | 1329 | (define program3 (string->zo (~a '(time-apply void '())))) ; application of primitives 1330 | (check-equal? (let-values ([(val _ __ ___) (eval-zo program3)]) val) (list (void))) 1331 | 1332 | (define program4 ; application of closure and localref 1333 | (string->zo (~a '(let () (define (foo x) x) (foo 43))))) 1334 | (check-equal? (eval-zo program4) 43) 1335 | 1336 | (define program5 ; check the order in which arguments are pushed to the stack: 1337 | (string->zo (~a '(let () (define (foo x y) (list x y)) (foo 41 42))))) 1338 | (check-equal? (eval-zo program5) (list 41 42)) 1339 | 1340 | 1341 | 1342 | (verbose "program6") 1343 | (define program6 ; check rest arguments 1344 | (string->zo (~a '(let()(define (foo x y . z) (list (+ x y) z)) (foo 41 42 43 44))))) 1345 | (check-equal? (eval-zo program6) '(83 (43 44))) 1346 | 1347 | (verbose "program7") 1348 | (define program7 (string->zo (~a '(let() (define (foo x) (set! x (+ x 1)) x) (foo 41))))) 1349 | (check-equal? (eval-zo program7) 42) 1350 | 1351 | (define program8 (string->zo 1352 | (~a '(let() (define (foo x y z) (set! y (+ x y z)) (list x y z)) (foo 41 42 43))))) 1353 | (check-equal? (eval-zo program8) '(41 126 43)) 1354 | 1355 | (define program9 ; let-one 1356 | (string->zo (~a '(let() (define-values (a b c) (values 41 42 43)) (set! b 44) (list a b c))))) 1357 | (check-equal? (eval-zo program9) '(41 44 43)) 1358 | 1359 | (verbose "program10") 1360 | (define program10 ; branch 1361 | (string->zo (~a '(let() (define (fact n) (if (zero? n) 1 (* n (fact (- n 1))))) (fact 5))))) 1362 | 1363 | ; test module-variable in prefix (build-list is imported form racket/list via racket/base) 1364 | (define program11 (string->zo (~a '(let () (build-list 3 values))))) 1365 | (check-equal? (eval-zo program11) '(0 1 2)) 1366 | 1367 | (define program12 ; beg0 1368 | (string->zo (~a '(let () (define (foo x) x) (begin0 (foo 42) 43))))) 1369 | (check-equal? (eval-zo program12) 42) 1370 | 1371 | (define program13 ; with-continuation-mark 1372 | (string->zo (~a '(let () 1373 | (define (extract-current-continuation-marks key) 1374 | (continuation-mark-set->list (current-continuation-marks) key)) 1375 | (with-continuation-mark 'key 'mark 1376 | (extract-current-continuation-marks 'key)))))) 1377 | (check-equal? (eval-zo program13) '(mark)) 1378 | 1379 | (define program14 ; seq 1380 | (string->zo (~a '(let () (define (foo x) x) (+ (begin (foo 41) 42) 43))))) 1381 | (check-equal? (eval-zo program14) 85) 1382 | 1383 | (verbose "program15") 1384 | (define program15 ; call-with-values 1385 | (string->zo (~a '(let () (define (foo x) x) (call-with-values (λ() (values (foo 42) 43)) list))))) 1386 | (check-equal? (eval-zo program15) '(42 43)) 1387 | 1388 | (define program16 ; case-lambda 1389 | (string->zo 1390 | (~a '(let () (define foo (case-lambda [(x) 41] [(x y) 42])) (list (foo 51) (foo 52 53)))))) 1391 | (check-equal? (eval-zo program16) '(41 42)) 1392 | 1393 | (define program17 ; case-lambda 1394 | (string->zo 1395 | (~a '(let () (define foo (case-lambda [(x . z) 41] [(x y) 42])) (list (foo 51) (foo 52 53)))))) 1396 | (check-equal? (eval-zo program17) '(41 41)) 1397 | 1398 | (define program18 ; call-with-values with a case-lambda 1399 | (string->zo (~a '(let () 1400 | (define (foo x) x) 1401 | (define bar (case-lambda [(x) 41] [(x y) 42])) 1402 | (call-with-values (λ() (values (foo 51) 52)) bar))))) 1403 | (check-equal? (eval-zo program18) 42) 1404 | 1405 | (define program19 ; call-with-values with a case-lambda 1406 | (string->zo (~a '(let () 1407 | (define (foo x) x) 1408 | (define bar (case-lambda [(x . z) 41] [(x y) 42])) 1409 | (call-with-values (λ() (values (foo 51) 52)) bar))))) 1410 | (check-equal? (eval-zo program19) 41) 1411 | 1412 | (verbose "program20") 1413 | (define program20 ; let-void and variable capture 1414 | (string->zo 1415 | (~a '(letrec ([foo (lambda (x) (if (zero? x) 41 (if (even? x) (bar x) (foo (- x 1)))))] 1416 | [bar (lambda (x) (if (zero? x) 42 (if (even? x) (foo (- x 1)) (bar (- x 1)))))] 1417 | [baz (lambda () (set! foo 43))] 1418 | ) 1419 | (foo 2))))) 1420 | (check-equal? (eval-zo program20) 41) 1421 | 1422 | (define program21 ; let-rec 1423 | (compile-zo '(letrec ([p (lambda (x) (+ 1 (q (- x 1))))] 1424 | [q (lambda (y) (if (zero? y) 0 (+ 1 (p (- y 1)))))] 1425 | [x (p 5)] 1426 | [y x]) 1427 | y))) 1428 | (check-equal? (eval-zo program21) 5) 1429 | 1430 | (define program22 ; assign and the form seq 1431 | (compile-zo '(let () (set! first first) first))) 1432 | (check-equal? (eval-zo program22) first) 1433 | 1434 | (define program23 ; top-level define-values 1435 | (compile-zo '(begin (define x 42) x))) 1436 | (check-equal? (eval-zo program23) 42) 1437 | 1438 | (define program24 ; topsyntax and stx in prefix 1439 | (compile-zo '#'42)) 1440 | ; Hmm. (equal? #'42 #'42) is #f, so check-equal? is not helpful here 1441 | ; (check-equal? (eval-zo program24) (racket-eval-zo program24)) 1442 | (check-equal? (syntax->datum (eval-zo program24)) 42) 1443 | 1444 | (verbose "program25") 1445 | (define program25 ; toplevel require 1446 | (compile-zo '(begin (require racket/port) port->list))) 1447 | ; (check-equal? (eval-zo program25) port->list) ; works but are not equal? ??? 1448 | 1449 | (verbose "program26") 1450 | ; Are lambda, case-lambe and let-rec producing closures? 1451 | (define program26a '(let ([x 41]) (λ (y) (list x y)))) 1452 | (define program26b '(let ([x 41]) (case-lambda [(y) (list x y)] [(y z) (list x y z)]))) 1453 | (define program26c '(letrec ([even? (lambda (x) (if (zero? x) #t (odd? (- x 1))))] 1454 | [odd? (lambda (x) (if (zero? x) #f (even? (- x 1))))]) 1455 | even?)) 1456 | (check-true (clos? (eval-zo program26a))) 1457 | (check-true (case-clos? (eval-zo program26b))) 1458 | (check-true (shell? (eval-zo program26c))) 1459 | ; Check that closures can be invoked by Racket procedures. 1460 | (check-equal? ((eval-zo program26a) 42) '(41 42)) 1461 | (check-equal? ((eval-zo program26b) 42) '(41 42)) 1462 | (check-equal? ((eval-zo program26b) 42 43) '(41 42 43)) 1463 | (check-true ((eval-zo program26c) 4)) 1464 | (check-false ((eval-zo program26c) 5)) 1465 | ; And by the interpreter 1466 | (check-equal? (eval-zo `(,program26a 42)) '(41 42)) 1467 | (check-equal? (eval-zo `(,program26b 42)) '(41 42)) 1468 | (check-equal? (eval-zo `(,program26b 42 43)) '(41 42 43)) 1469 | (check-true (eval-zo `(,program26c 4))) 1470 | (check-false (eval-zo `(,program26c 5))) 1471 | 1472 | (verbose "program27") 1473 | (use-current) 1474 | (define program27 ; seq-for-syntax 1475 | '(begin (define x 40) (begin-for-syntax (define x 41)) x)) 1476 | (parameterize ([current-namespace (variable-reference->namespace (#%variable-reference))]) 1477 | (check-equal? (eval-zo program27) 40)) 1478 | 1479 | 1480 | (verbose "program28") 1481 | (use-current) 1482 | (parameterize ([current-namespace (variable-reference->namespace (#%variable-reference))]) 1483 | ; (with-start-namespace (dynamic-require-for-syntax 'racket/base 0) 1484 | (check-equal? (eval-zo '(begin (define x 1) 1485 | (define-syntax (y _) #'x) 1486 | x)) 1487 | 1)) 1488 | 1489 | (verbose "R6RS TEST SUITE") 1490 | (use-start) 1491 | ;;; 1492 | ;;; FROM THE R6RS TEST SUITE 1493 | ;;; 1494 | 1495 | (require (for-syntax syntax/parse racket/base)) 1496 | (define test-program 'none) 1497 | (define test-zo 'none) 1498 | 1499 | ; (define-syntax (test stx) #'(void)) ; for disabling tests 1500 | 1501 | (define-syntax (test stx) 1502 | (syntax-parse stx 1503 | [(_ s-exp expected) 1504 | (with-syntax ([t (datum->syntax #'stx 'test #'s-exp)] 1505 | [loc (datum->syntax #'stx (syntax->datum #''s-exp) #'s-exp)]) 1506 | #`(begin 1507 | (set! test-zo 'none) 1508 | (set! test-program 's-exp) 1509 | (define zo (compile-zo 's-exp)) 1510 | (set! test-zo zo) 1511 | (define actual (eval-zo zo)) 1512 | (unless (equal? actual expected) 1513 | (raise-syntax-error 'test 1514 | (~a "test failed\n expected: " expected "\n actual: " actual "\n") 1515 | #'s-exp))))])) 1516 | (test 42 42) 1517 | ; (test (+ 1 2) 4) 1518 | 1519 | ;; Expressions ---------------------------------------- 1520 | ;;; Test-suite from: http://svn.plt-scheme.org/plt/trunk/collects/tests/r6rs/base.sls 1521 | 1522 | (verbose "11.2.1") 1523 | ;(test (add3 3) 6) 1524 | (test (first '(1 2)) 1) 1525 | 1526 | (verbose "11.2.2") 1527 | (test (let () 1528 | (define even? 1529 | (lambda (x) 1530 | (or (= x 0) (odd? (- x 1))))) 1531 | (define-syntax odd? 1532 | (syntax-rules () 1533 | ((odd? x) (not (even? x))))) 1534 | (even? 10)) 1535 | #t) 1536 | (test (let () 1537 | (define-syntax bind-to-zero 1538 | (syntax-rules () 1539 | ((bind-to-zero id) (define id 0)))) 1540 | (bind-to-zero x) 1541 | x) 1542 | 0) 1543 | 1544 | (verbose "11.3") 1545 | (test (let ((x 5)) 1546 | (define foo (lambda (y) (bar x y))) 1547 | (define bar (lambda (a b) (+ (* a b) a))) 1548 | (foo (+ x 3))) 1549 | 45) 1550 | (test (let ((x 5)) 1551 | (letrec ((foo (lambda (y) (bar x y))) 1552 | (bar (lambda (a b) (+ (* a b) a)))) 1553 | (foo (+ x 3)))) 1554 | 45) 1555 | 1556 | #;(test/exn (letrec ([x y] 1557 | [y x]) 1558 | 'should-not-get-here) 1559 | &assertion) 1560 | 1561 | (test (letrec ([x (if (eq? (cons 1 2) (cons 1 2)) 1562 | x 1563 | 1)]) 1564 | x) 1565 | 1) 1566 | 1567 | (verbose "11.4.1") 1568 | ;; (These tests are especially silly, since they really 1569 | ;; have to work to get this far.) 1570 | (test (quote a) 'a) 1571 | (test (quote #(a b c)) (vector 'a 'b 'c)) 1572 | (test (quote (+ 1 2)) '(+ 1 2)) 1573 | (test '"abc" "abc") 1574 | (test '145932 145932) 1575 | (test 'a 'a) 1576 | (test '#(a b c) (vector 'a 'b 'c)) 1577 | (test '() (list)) 1578 | (test '(+ 1 2) '(+ 1 2)) 1579 | (test '(quote a) '(quote a)) 1580 | (test ''a '(quote a)) 1581 | 1582 | (verbose "11.4.2") 1583 | ;; (test (lambda (x) (+ x x)) {a procedure}) 1584 | (test ((lambda (x) (+ x x)) 4) 8) 1585 | (test ((lambda (x) 1586 | (define (p y) 1587 | (+ y 1)) 1588 | (+ (p x) x)) 1589 | 5) 1590 | 11) 1591 | ;(test (reverse-subtract 7 10) 3) 1592 | ;(test (add4 6) 10) 1593 | (test ((lambda x x) 3 4 5 6) '(3 4 5 6)) 1594 | (test ((lambda (x y . z) z) 3 4 5 6) 1595 | '(5 6)) 1596 | 1597 | (verbose "11.4.3") 1598 | (test (if (> 3 2) 'yes 'no) 'yes) 1599 | (test (if (> 2 3) 'yes 'no) 'no) 1600 | (test (if (> 3 2) 1601 | (- 3 2) 1602 | (+ 3 2)) 1603 | 1) 1604 | ;(test/unspec (if #f #f)) 1605 | 1606 | (verbose "11.4.4") 1607 | (test (let ((x 2)) 1608 | (+ x 1) 1609 | (set! x 4) 1610 | (+ x 1)) 1611 | 5) 1612 | 1613 | (verbose "11.4.5") 1614 | (test (cond ((> 3 2) 'greater) 1615 | ((< 3 2) 'less)) 1616 | 'greater) 1617 | 1618 | (test (cond ((> 3 3) 'greater) 1619 | ((< 3 3) 'less) 1620 | (else 'equal)) 1621 | 'equal) 1622 | (test (cond ('(1 2 3) => cadr) 1623 | (else #t)) 1624 | 2) 1625 | 1626 | (test (case (* 2 3) 1627 | ((2 3 5 7) 'prime) 1628 | ((1 4 6 8 9) 'composite)) 1629 | 'composite) 1630 | #;(test/unspec (case (car '(c d)) 1631 | ((a) 'a) 1632 | ((b) 'b))) 1633 | (test (case (car '(c d)) 1634 | ((a e i o u) 'vowel) 1635 | ((w y) 'semivowel) 1636 | (else 'consonant)) 1637 | 'consonant) 1638 | 1639 | (test (and (= 2 2) (> 2 1)) #t) 1640 | (test (and (= 2 2) (< 2 1)) #f) 1641 | (test (and 1 2 'c '(f g)) '(f g)) 1642 | (test (and) #t) 1643 | 1644 | (test (or (= 2 2) (> 2 1)) #t) 1645 | (test (or (= 2 2) (< 2 1)) #t) 1646 | (test (or #f #f #f) #f) 1647 | (test (or '(b c) (/ 3 0)) '(b c)) 1648 | 1649 | (verbose "11.4.6") 1650 | (test (let ((x 2) (y 3)) (* x y)) 6) 1651 | (test (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))) 35) 1652 | (test (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))) 70) 1653 | (test (letrec ((even? 1654 | (lambda (n) 1655 | (if (zero? n) 1656 | #t 1657 | (odd? (- n 1))))) 1658 | (odd? 1659 | (lambda (n) 1660 | (if (zero? n) 1661 | #f 1662 | (even? (- n 1)))))) 1663 | (even? 88)) 1664 | #t) 1665 | (test (letrec ((p ; was letrec* 1666 | (lambda (x) 1667 | (+ 1 (q (- x 1))))) 1668 | (q 1669 | (lambda (y) 1670 | (if (zero? y) 1671 | 0 1672 | (+ 1 (p (- y 1)))))) 1673 | (x (p 5)) 1674 | (y x)) 1675 | y) 1676 | 5) 1677 | (test (let-values (((a b) (values 1 2)) 1678 | ((c d) (values 3 4))) 1679 | (list a b c d)) 1680 | '(1 2 3 4)) 1681 | #;(test (let-values (((a b . c) (values 1 2 3 4))) ; let-values with rest args not in Racket 1682 | (list a b c)) 1683 | '(1 2 (3 4))) 1684 | (test (let ((a 'a) (b 'b) (x 'x) (y 'y)) 1685 | (let-values (((a b) (values x y)) 1686 | ((x y) (values a b))) 1687 | (list a b x y))) 1688 | '(x y a b)) 1689 | (test (let ((a 'a) (b 'b) (x 'x) (y 'y)) 1690 | (let*-values (((a b) (values x y)) 1691 | ((x y) (values a b))) 1692 | (list a b x y))) 1693 | '(x y x y)) 1694 | 1695 | (verbose "11.6") 1696 | (test (procedure? car) #t) 1697 | (test (procedure? 'car) #f) 1698 | (test (procedure? (lambda (x) (* x x))) #t) 1699 | (test (procedure? '(lambda (x) (* x x))) #f) 1700 | 1701 | (test (call-with-values * -) -1) 1702 | 1703 | (verbose "11.16") 1704 | (test (let loop ((numbers '(3 -2 1 6 -5)) 1705 | (nonneg '()) 1706 | (neg '())) 1707 | (cond ((null? numbers) (list nonneg neg)) 1708 | ((>= (car numbers) 0) 1709 | (loop (cdr numbers) 1710 | (cons (car numbers) nonneg) 1711 | neg)) 1712 | ((< (car numbers) 0) 1713 | (loop (cdr numbers) 1714 | nonneg 1715 | (cons (car numbers) neg))))) 1716 | '((6 1 3) (-5 -2))) 1717 | 1718 | (use-current) 1719 | 1720 | (current-namespace (variable-reference->namespace (#%variable-reference))) 1721 | 1722 | #;(begin ; works but noisy 1723 | (verbose "module1") 1724 | (use-current) 1725 | (with-start-namespace 1726 | (eval-zo (compile-zo '(module m racket/base (provide x) (displayln "-- m --") (define x 42) x))) 1727 | (eval-zo (compile-zo '(require 'm))) 1728 | (eval-zo (compile-zo '(module n racket/base (require 'm) (provide y) (displayln "-- n --") (define y x) y))) 1729 | (eval-zo (compile-zo '(require 'n))))) 1730 | 1731 | #;(begin ; Works - but noisy 1732 | (verbose "module2") 1733 | (with-start-namespace 1734 | (eval-zo (compile-zo '(module m racket/base 1735 | (provide x y) 1736 | (displayln "-- m --") 1737 | (define x 40) 1738 | (define y (+ x 1)) 1739 | (list x y)))) 1740 | (eval-zo (compile-zo '(require 'm))) 1741 | (eval-zo (compile-zo '(module n racket/base 1742 | (require 'm) 1743 | (provide z) 1744 | (displayln "-- n --") 1745 | (define z (list x y)) 1746 | z))) 1747 | (eval-zo (compile-zo '(require 'n))))) 1748 | 1749 | 1750 | ;;; 1751 | ;;; WELCOME 1752 | ;;; 1753 | 1754 | (use-start) 1755 | ; (use-current) 1756 | 1757 | (displayln "Welcome to the Meta Racket VM") 1758 | (displayln (~a "Mode: 'start (which means make-start-namespace is used as default)")) 1759 | ; (displayln (~a "Mode: 'current (which means (current-namespace) is used as default)")) 1760 | (displayln "Use (use-curent) to use (current-namespace) as default") 1761 | (displayln "Use (use-start) to use (make-start-namespace) as default") 1762 | (newline) 1763 | (displayln "(eval-zo s-expr) : evaluate s-expression") 1764 | (displayln "(expand-zo s-expr) : expand s-expression") 1765 | (displayln "(compile-zo s-expr) : compile s-expression to zo bytecode") 1766 | (newline) 1767 | (displayln "In (use-current) mode the compiler use the current-environment.") 1768 | (displayln "When used in DrRacket it means that the language settings effect,") 1769 | (displayln "the bytecodes produced by the compiler. You might want to disable ") 1770 | (displayln "debugging and stack tracing to get sensible bytecodes.") 1771 | (displayln "In (use-start) mode the environment is controlled, but definitions") 1772 | (displayln "made in the repl won't be picked up.") 1773 | (newline) 1774 | 1775 | (displayln "Happy Rackeetering! -- Jens Axel (jensaxel@soegaard.net)") 1776 | 1777 | 1778 | --------------------------------------------------------------------------------