splitting off into some modules.
This commit is contained in:
Danny Yoo
parent
3755768485
commit
2025b90140
226
assemble.rkt
Normal file
226
assemble.rkt
Normal file
|
|
@ -0,0 +1,226 @@
|
|||
#lang racket/base
|
||||
(require "structs.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
(define-struct basic-block (name stmts) #:transparent)
|
||||
(define (fracture stmts)
|
||||
(let loop ([name (make-label 'start)]
|
||||
[acc '()]
|
||||
[basic-blocks '()]
|
||||
[stmts stmts]
|
||||
[last-stmt-goto? #f])
|
||||
(cond
|
||||
[(null? stmts)
|
||||
(reverse (cons (make-basic-block name (reverse acc))
|
||||
basic-blocks))]
|
||||
[(symbol? (car stmts))
|
||||
(loop (car stmts)
|
||||
'()
|
||||
(cons (make-basic-block name
|
||||
(if last-stmt-goto?
|
||||
(reverse acc)
|
||||
(reverse (append `((goto (label ,(car stmts))))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
(tagged-list? (car stmts) 'goto))]
|
||||
[else
|
||||
(loop name
|
||||
(cons (car stmts) acc)
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
(tagged-list? (car stmts) 'goto))])))
|
||||
|
||||
|
||||
;; assemble-basic-block: basic-block -> string
|
||||
(define (assemble-basic-block a-basic-block)
|
||||
(format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
|
||||
(basic-block-name a-basic-block)
|
||||
(basic-block-name a-basic-block)
|
||||
(string-join (map assemble-stmt (basic-block-stmts a-basic-block))
|
||||
"\n")))
|
||||
|
||||
(define (location? stmt)
|
||||
(or (tagged-list? stmt 'reg)
|
||||
(tagged-list? stmt 'label)))
|
||||
|
||||
(define (const? stmt)
|
||||
(tagged-list? stmt 'const))
|
||||
|
||||
(define (reg? s)
|
||||
(tagged-list? s 'reg))
|
||||
|
||||
(define (label? s)
|
||||
(tagged-list? s 'label))
|
||||
|
||||
(define (op? s)
|
||||
(tagged-list? s 'op))
|
||||
|
||||
(define (op-name s)
|
||||
(cadr s))
|
||||
|
||||
;; assemble-stmt: stmt -> string
|
||||
(define (assemble-stmt stmt)
|
||||
(cond
|
||||
[(tagged-list? stmt 'assign)
|
||||
(cond
|
||||
[(reg? (caddr stmt))
|
||||
(format "MACHINE.~a=~a"
|
||||
(cadr stmt)
|
||||
(assemble-reg (caddr stmt)))]
|
||||
[(label? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;" (cadr stmt)
|
||||
(assemble-label (caddr stmt)))]
|
||||
[(const? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;"
|
||||
(cadr stmt)
|
||||
(assemble-const (caddr stmt)))]
|
||||
[(op? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;"
|
||||
(cadr stmt)
|
||||
(assemble-op-expression (op-name (caddr stmt))
|
||||
(cdddr stmt)))]
|
||||
[else
|
||||
(error 'assemble "~a" stmt)])]
|
||||
[(tagged-list? stmt 'perform)
|
||||
(assemble-op-statement (op-name (cadr stmt))
|
||||
(cddr stmt))]
|
||||
[(tagged-list? stmt 'test)
|
||||
(format "if(~a){"
|
||||
(assemble-op-expression (op-name (cadr stmt))
|
||||
(cddr stmt)))]
|
||||
[(tagged-list? stmt 'branch)
|
||||
;; the unbalanced } is deliberate: test and branch always follow each other.
|
||||
(format "return ~a();}"
|
||||
(assemble-location (cadr stmt)))]
|
||||
[(tagged-list? stmt 'goto)
|
||||
(format "return ~a();"
|
||||
(assemble-location (cadr stmt)))]
|
||||
[(tagged-list? stmt 'save)
|
||||
(format "MACHINE.stack.push(MACHINE.~a);"
|
||||
(cadr stmt))]
|
||||
[(tagged-list? stmt 'restore)
|
||||
(format "MACHINE.~a=MACHINE.stack.pop();"
|
||||
(cadr stmt))]
|
||||
[else (error 'assemble "~a" stmt)]))
|
||||
|
||||
;; fixme: use js->string
|
||||
(define (assemble-const stmt)
|
||||
(let loop ([val (cadr stmt)])
|
||||
(cond [(symbol? val)
|
||||
(format "~s" (symbol->string val))]
|
||||
[(list? val)
|
||||
(format "_list(~a)" (string-join (map loop val)
|
||||
","))]
|
||||
[else
|
||||
(format "~s" val)])))
|
||||
|
||||
(define (assemble-op-expression op-name inputs)
|
||||
(let ([assembled-inputs (map assemble-input inputs)])
|
||||
(case op-name
|
||||
;; open coding some of the primitive operations:
|
||||
[(compiled-procedure-entry)
|
||||
(format "(~a.label)" (assemble-input (first inputs)))]
|
||||
[(compiled-procedure-env)
|
||||
(format "(~a.env)" (assemble-input (first inputs)))]
|
||||
[(make-compiled-procedure)
|
||||
(format "(new Closure(~a, ~a))"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[(false?)
|
||||
(format "(!(~a))" (assemble-input (first inputs)))]
|
||||
[(cons)
|
||||
(format "[~a]" (string-join (map assemble-input inputs) ","))]
|
||||
[(list)
|
||||
(cond [(empty? inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(let loop ([assembled-inputs assembled-inputs])
|
||||
(cond
|
||||
[(empty? assembled-inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(format "[~a, ~a]"
|
||||
(first assembled-inputs)
|
||||
(loop (rest assembled-inputs)))]))])]
|
||||
[(apply-primitive-procedure)
|
||||
(format "~a(~a)"
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(lexical-address-lookup)
|
||||
(format "(~a).valss[~a][~a]"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(primitive-procedure?)
|
||||
(format "(typeof(~a) === 'function')"
|
||||
(first assembled-inputs))]
|
||||
[(extend-environment)
|
||||
(format "(new ExtendedEnvironment(~a, ~a)"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[(lookup-variable-value)
|
||||
(format "((~a).globalBindings[~a])"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[else
|
||||
(error 'assemble "~e" op-name)])))
|
||||
|
||||
|
||||
(define (assemble-op-statement op-name inputs)
|
||||
(let ([assembled-inputs (map assemble-input inputs)])
|
||||
(case op-name
|
||||
[(define-variable!)
|
||||
(format "(~a).globalBindings[~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(set-variable-value!)
|
||||
(format "(~a).globalBindings[~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(lexical-address-set!)
|
||||
(format "(~a).valss[~a][~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs)
|
||||
(fourth assembled-inputs))]
|
||||
[(check-bound-global!)
|
||||
(format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[else
|
||||
(error 'assemble-op-statement "~a" op-name)])))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (assemble-input an-input)
|
||||
(cond
|
||||
[(reg? an-input)
|
||||
(assemble-reg an-input)]
|
||||
[(const? an-input)
|
||||
(assemble-const an-input)]
|
||||
[(label? an-input)
|
||||
(assemble-label an-input)]
|
||||
[else (error 'assemble-input "~e" an-input)]))
|
||||
|
||||
(define (assemble-location a-location)
|
||||
(cond
|
||||
[(reg? a-location)
|
||||
(assemble-reg a-location)]
|
||||
[(label? a-location)
|
||||
(assemble-label a-location)]
|
||||
[else (error 'assemble-location "~e" a-location)]))
|
||||
|
||||
(define (assemble-reg a-reg)
|
||||
(string-append "MACHINE." (symbol->string (cadr a-reg))))
|
||||
|
||||
(define (assemble-label a-label)
|
||||
(symbol->string (cadr a-label)))
|
||||
307
cm.rkt
307
cm.rkt
|
|
@ -1,5 +1,8 @@
|
|||
#lang racket
|
||||
#lang racket/base
|
||||
|
||||
(require "structs.rkt"
|
||||
"assemble.rkt"
|
||||
racket/list)
|
||||
|
||||
;; SICP, Chapter 5.5
|
||||
|
||||
|
|
@ -381,21 +384,6 @@
|
|||
|
||||
|
||||
|
||||
;; instruction sequences
|
||||
(define-struct instruction-sequence (needs modifies statements) #:transparent)
|
||||
|
||||
(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
|
||||
|
||||
(define (make-label l)
|
||||
(gensym l))
|
||||
|
||||
|
||||
(define (registers-needed s)
|
||||
(if (symbol? s) '() (instruction-sequence-needs s)))
|
||||
(define (registers-modified s)
|
||||
(if (symbol? s) '() (instruction-sequence-modifies s)))
|
||||
(define (statements s)
|
||||
(if (symbol? s) (list s) (instruction-sequence-statements s)))
|
||||
|
||||
|
||||
(define (needs-register? seq reg)
|
||||
|
|
@ -479,295 +467,8 @@
|
|||
|
||||
|
||||
|
||||
;; expression selectors
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond
|
||||
[(number? exp) #t]
|
||||
[(string? exp) #t]
|
||||
[else #f]))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
(define (quoted? exp) (tagged-list? exp 'quote))
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
#f))
|
||||
|
||||
(define (assignment? exp)
|
||||
(tagged-list? exp 'set!))
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
(define (definition? exp)
|
||||
(tagged-list? exp 'define))
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp)
|
||||
(cddr exp))))
|
||||
|
||||
(define (lambda? exp)
|
||||
(tagged-list? exp 'lambda))
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
|
||||
(define (if? exp)
|
||||
(tagged-list? exp 'if))
|
||||
(define (if-predicate exp)
|
||||
(cadr exp))
|
||||
(define (if-consequent exp)
|
||||
(caddr exp))
|
||||
(define (if-alternative exp)
|
||||
(if (not (null? (cdddr exp)))
|
||||
(cadddr exp)
|
||||
'false))
|
||||
|
||||
(define (begin? exp)
|
||||
(tagged-list? exp 'begin))
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct basic-block (name stmts) #:transparent)
|
||||
(define (fracture stmts)
|
||||
(let loop ([name (make-label 'start)]
|
||||
[acc '()]
|
||||
[basic-blocks '()]
|
||||
[stmts stmts]
|
||||
[last-stmt-goto? #f])
|
||||
(cond
|
||||
[(null? stmts)
|
||||
(reverse (cons (make-basic-block name (reverse acc))
|
||||
basic-blocks))]
|
||||
[(symbol? (car stmts))
|
||||
(loop (car stmts)
|
||||
'()
|
||||
(cons (make-basic-block name
|
||||
(if last-stmt-goto?
|
||||
(reverse acc)
|
||||
(reverse (append `((goto (label ,(car stmts))))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
(tagged-list? (car stmts) 'goto))]
|
||||
[else
|
||||
(loop name
|
||||
(cons (car stmts) acc)
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
(tagged-list? (car stmts) 'goto))])))
|
||||
|
||||
|
||||
;; assemble-basic-block: basic-block -> string
|
||||
(define (assemble-basic-block a-basic-block)
|
||||
(format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
|
||||
(basic-block-name a-basic-block)
|
||||
(basic-block-name a-basic-block)
|
||||
(string-join (map assemble-stmt (basic-block-stmts a-basic-block))
|
||||
"\n")))
|
||||
|
||||
(define (location? stmt)
|
||||
(or (tagged-list? stmt 'reg)
|
||||
(tagged-list? stmt 'label)))
|
||||
|
||||
(define (const? stmt)
|
||||
(tagged-list? stmt 'const))
|
||||
|
||||
(define (reg? s)
|
||||
(tagged-list? s 'reg))
|
||||
|
||||
(define (label? s)
|
||||
(tagged-list? s 'label))
|
||||
|
||||
(define (op? s)
|
||||
(tagged-list? s 'op))
|
||||
|
||||
(define (op-name s)
|
||||
(cadr s))
|
||||
|
||||
;; assemble-stmt: stmt -> string
|
||||
(define (assemble-stmt stmt)
|
||||
(cond
|
||||
[(tagged-list? stmt 'assign)
|
||||
(cond
|
||||
[(reg? (caddr stmt))
|
||||
(format "MACHINE.~a=~a"
|
||||
(cadr stmt)
|
||||
(assemble-reg (caddr stmt)))]
|
||||
[(label? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;" (cadr stmt)
|
||||
(assemble-label (caddr stmt)))]
|
||||
[(const? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;"
|
||||
(cadr stmt)
|
||||
(assemble-const (caddr stmt)))]
|
||||
[(op? (caddr stmt))
|
||||
(format "MACHINE.~a=~a;"
|
||||
(cadr stmt)
|
||||
(assemble-op-expression (op-name (caddr stmt))
|
||||
(cdddr stmt)))]
|
||||
[else
|
||||
(error 'assemble "~a" stmt)])]
|
||||
[(tagged-list? stmt 'perform)
|
||||
(assemble-op-statement (op-name (cadr stmt))
|
||||
(cddr stmt))]
|
||||
[(tagged-list? stmt 'test)
|
||||
(format "if(~a){"
|
||||
(assemble-op-expression (op-name (cadr stmt))
|
||||
(cddr stmt)))]
|
||||
[(tagged-list? stmt 'branch)
|
||||
;; the unbalanced } is deliberate: test and branch always follow each other.
|
||||
(format "return ~a();}"
|
||||
(assemble-location (cadr stmt)))]
|
||||
[(tagged-list? stmt 'goto)
|
||||
(format "return ~a();"
|
||||
(assemble-location (cadr stmt)))]
|
||||
[(tagged-list? stmt 'save)
|
||||
(format "MACHINE.stack.push(MACHINE.~a);"
|
||||
(cadr stmt))]
|
||||
[(tagged-list? stmt 'restore)
|
||||
(format "MACHINE.~a=MACHINE.stack.pop();"
|
||||
(cadr stmt))]
|
||||
[else (error 'assemble "~a" stmt)]))
|
||||
|
||||
;; fixme: use js->string
|
||||
(define (assemble-const stmt)
|
||||
(let loop ([val (cadr stmt)])
|
||||
(cond [(symbol? val)
|
||||
(format "~s" (symbol->string val))]
|
||||
[(list? val)
|
||||
(format "_list(~a)" (string-join (map loop val)
|
||||
","))]
|
||||
[else
|
||||
(format "~s" val)])))
|
||||
|
||||
(define (assemble-op-expression op-name inputs)
|
||||
(let ([assembled-inputs (map assemble-input inputs)])
|
||||
(case op-name
|
||||
;; open coding some of the primitive operations:
|
||||
[(compiled-procedure-entry)
|
||||
(format "(~a.label)" (assemble-input (first inputs)))]
|
||||
[(compiled-procedure-env)
|
||||
(format "(~a.env)" (assemble-input (first inputs)))]
|
||||
[(make-compiled-procedure)
|
||||
(format "(new Closure(~a, ~a))"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[(false?)
|
||||
(format "(!(~a))" (assemble-input (first inputs)))]
|
||||
[(cons)
|
||||
(format "[~a]" (string-join (map assemble-input inputs) ","))]
|
||||
[(list)
|
||||
(cond [(empty? inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(let loop ([assembled-inputs assembled-inputs])
|
||||
(cond
|
||||
[(empty? assembled-inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(format "[~a, ~a]"
|
||||
(first assembled-inputs)
|
||||
(loop (rest assembled-inputs)))]))])]
|
||||
[(apply-primitive-procedure)
|
||||
(format "~a(~a)"
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(lexical-address-lookup)
|
||||
(format "(~a).valss[~a][~a]"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(primitive-procedure?)
|
||||
(format "(typeof(~a) === 'function')"
|
||||
(first assembled-inputs))]
|
||||
[(extend-environment)
|
||||
(format "(new ExtendedEnvironment(~a, ~a)"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[(lookup-variable-value)
|
||||
(format "((~a).globalBindings[~a])"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[else
|
||||
(error 'assemble "~e" op-name)])))
|
||||
|
||||
|
||||
(define (assemble-op-statement op-name inputs)
|
||||
(let ([assembled-inputs (map assemble-input inputs)])
|
||||
(case op-name
|
||||
[(define-variable!)
|
||||
(format "(~a).globalBindings[~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(set-variable-value!)
|
||||
(format "(~a).globalBindings[~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
[(lexical-address-set!)
|
||||
(format "(~a).valss[~a][~a] = ~a;"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs)
|
||||
(fourth assembled-inputs))]
|
||||
[(check-bound-global!)
|
||||
(format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
[else
|
||||
(error 'assemble-op-statement "~a" op-name)])))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (assemble-input an-input)
|
||||
(cond
|
||||
[(reg? an-input)
|
||||
(assemble-reg an-input)]
|
||||
[(const? an-input)
|
||||
(assemble-const an-input)]
|
||||
[(label? an-input)
|
||||
(assemble-label an-input)]
|
||||
[else (error 'assemble-input "~e" an-input)]))
|
||||
|
||||
(define (assemble-location a-location)
|
||||
(cond
|
||||
[(reg? a-location)
|
||||
(assemble-reg a-location)]
|
||||
[(label? a-location)
|
||||
(assemble-label a-location)]
|
||||
[else (error 'assemble-location "~e" a-location)]))
|
||||
|
||||
(define (assemble-reg a-reg)
|
||||
(string-append "MACHINE." (symbol->string (cadr a-reg))))
|
||||
|
||||
(define (assemble-label a-label)
|
||||
(symbol->string (cadr a-label)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
90
structs.rkt
Normal file
90
structs.rkt
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; expression selectors
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond
|
||||
[(number? exp) #t]
|
||||
[(string? exp) #t]
|
||||
[else #f]))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
(define (quoted? exp) (tagged-list? exp 'quote))
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
#f))
|
||||
|
||||
(define (assignment? exp)
|
||||
(tagged-list? exp 'set!))
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
(define (definition? exp)
|
||||
(tagged-list? exp 'define))
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp)
|
||||
(cddr exp))))
|
||||
|
||||
(define (lambda? exp)
|
||||
(tagged-list? exp 'lambda))
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
|
||||
(define (if? exp)
|
||||
(tagged-list? exp 'if))
|
||||
(define (if-predicate exp)
|
||||
(cadr exp))
|
||||
(define (if-consequent exp)
|
||||
(caddr exp))
|
||||
(define (if-alternative exp)
|
||||
(if (not (null? (cdddr exp)))
|
||||
(cadddr exp)
|
||||
'false))
|
||||
|
||||
(define (begin? exp)
|
||||
(tagged-list? exp 'begin))
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; instruction sequences
|
||||
(define-struct instruction-sequence (needs modifies statements) #:transparent)
|
||||
|
||||
(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
|
||||
|
||||
(define (make-label l)
|
||||
(gensym l))
|
||||
|
||||
|
||||
(define (registers-needed s)
|
||||
(if (symbol? s) '() (instruction-sequence-needs s)))
|
||||
(define (registers-modified s)
|
||||
(if (symbol? s) '() (instruction-sequence-modifies s)))
|
||||
(define (statements s)
|
||||
(if (symbol? s) (list s) (instruction-sequence-statements s)))
|
||||
Loading…
Reference in New Issue
Block a user