conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* libintelasm librarified

This commit is contained in:
Abdulaziz Ghuloum 2007-04-30 23:46:31 -04:00
parent 572b97c769
commit 1e54a6e8da
3 changed files with 68 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

4
src/libintelasm.ss
View File

@ -37,7 +37,9 @@
;;; setg ;;; setg
(let () (library (ikarus intel-assember)
(export)
(import (scheme))
(define fold (define fold
(lambda (f init ls) (lambda (f init ls)

80
src/syntax.ss
View File

@ -179,6 +179,16 @@
(lambda (x y) (lambda (x y)
(and (eq? (id->sym x) (id->sym y)) (and (eq? (id->sym x) (id->sym y))
(same-marks? (stx-mark* x) (stx-mark* y))))) (same-marks? (stx-mark* x) (stx-mark* y)))))
(define-syntax bound-id-member?
(lambda (x)
(syntax-case x ()
[x (identifier? #'x) #'bound-id-member?^]
[(_ id id*)
#'(let ([t1 id] [t2 id*])
(unless (and (id? t1) (andmap id? t2))
(error 'bound-id-member? "~s ~s is not an id in ~s" t1 t2
'(_ id id*)))
(bound-id-member?^ t1 t2))])))
(define free-id=? (define free-id=?
(lambda (i j) (lambda (i j)
(let ((t0 (id->label i)) (t1 (id->label j))) (let ((t0 (id->label i)) (t1 (id->label j)))
@ -194,11 +204,11 @@
(or (null? id*) (or (null? id*)
(and (not (bound-id-member? (car id*) (cdr id*))) (and (not (bound-id-member? (car id*) (cdr id*)))
(distinct-bound-ids? (cdr id*)))))) (distinct-bound-ids? (cdr id*))))))
(define bound-id-member? (define bound-id-member?^
(lambda (id id*) (lambda (id id*)
(and (pair? id*) (and (pair? id*)
(or (bound-id=? id (car id*)) (or (bound-id=? id (car id*))
(bound-id-member? id (cdr id*)))))) (bound-id-member?^ id (cdr id*))))))
(define self-evaluating? (define self-evaluating?
(lambda (x) (lambda (x)
(or (number? x) (string? x) (char? x) (boolean? x)))) (or (number? x) (string? x) (char? x) (boolean? x))))
@ -211,6 +221,11 @@
(define extend-env* (define extend-env*
(lambda (lab* b* r) (lambda (lab* b* r)
(append (map cons lab* b*) r))) (append (map cons lab* b*) r)))
(define cons-id
(lambda (kwd kwd*)
(if (id? kwd)
(cons kwd kwd*)
kwd*)))
(define strip (define strip
(lambda (x m*) (lambda (x m*)
(if (top-marked? m*) (if (top-marked? m*)
@ -567,6 +582,14 @@
[cdar cdar-label (core-prim . cdar)] [cdar cdar-label (core-prim . cdar)]
[cadr cadr-label (core-prim . cadr)] [cadr cadr-label (core-prim . cadr)]
[cddr cddr-label (core-prim . cddr)] [cddr cddr-label (core-prim . cddr)]
[caaar caaar-label (core-prim . caaar)]
[cdaar cdaar-label (core-prim . cdaar)]
[cadar cadar-label (core-prim . cadar)]
[cddar cddar-label (core-prim . cddar)]
[caadr caadr-label (core-prim . caadr)]
[cdadr cdadr-label (core-prim . cdadr)]
[caddr caddr-label (core-prim . caddr)]
[cdddr cdddr-label (core-prim . cdddr)]
[list list-label (core-prim . list)] [list list-label (core-prim . list)]
[list-ref list-ref-label (core-prim . list-ref)] [list-ref list-ref-label (core-prim . list-ref)]
[make-list make-list-label (core-prim . make-list)] [make-list make-list-label (core-prim . make-list)]
@ -700,7 +723,9 @@
[* *-label (core-prim . *)] [* *-label (core-prim . *)]
[+ plus-label (core-prim . +)] [+ plus-label (core-prim . +)]
[number? number?-label (core-prim . number?)] [number? number?-label (core-prim . number?)]
[integer? integer?-label (core-prim . integer?)]
[quotient quotient-label (core-prim . quotient)] [quotient quotient-label (core-prim . quotient)]
[remainder remainder-label (core-prim . remainder)]
[number->string number->string-label (core-prim . number->string)] [number->string number->string-label (core-prim . number->string)]
[string->number string->number-label (core-prim . string->number)] [string->number string->number-label (core-prim . string->number)]
;;; symbols/gensyms ;;; symbols/gensyms
@ -876,13 +901,16 @@
;;; codes ;;; codes
[$closure-code $closure-code-label (core-prim . $closure-code)] [$closure-code $closure-code-label (core-prim . $closure-code)]
[$code? $code?-label (core-prim . $code?)] [$code? $code?-label (core-prim . $code?)]
[$code->closure $code->closure-label (core-prim . $code->closure)]
[$code-reloc-vector $code-reloc-vector-label (core-prim . $code-reloc-vector)] [$code-reloc-vector $code-reloc-vector-label (core-prim . $code-reloc-vector)]
[$code-freevars $code-freevars-label (core-prim . $code-freevars)] [$code-freevars $code-freevars-label (core-prim . $code-freevars)]
[$code-size $code-size-label (core-prim . $code-size)] [$code-size $code-size-label (core-prim . $code-size)]
[$code-ref $code-ref-label (core-prim . $code-ref)] [$code-ref $code-ref-label (core-prim . $code-ref)]
[$code-set! $code-set!-label (core-prim . $code-set!)] [$code-set! $code-set!-label (core-prim . $code-set!)]
[code? code?-label (core-prim . code?)] [code? code?-label (core-prim . code?)]
[make-code make-code-label (core-prim . make-code)]
[code-reloc-vector code-reloc-vector-label (core-prim . code-reloc-vector)] [code-reloc-vector code-reloc-vector-label (core-prim . code-reloc-vector)]
[set-code-reloc-vector! set-code-reloc-vector!-label (core-prim . set-code-reloc-vector!)]
[code-size code-size-label (core-prim . code-size)] [code-size code-size-label (core-prim . code-size)]
[code-freevars code-freevars-label (core-prim . code-freevars)] [code-freevars code-freevars-label (core-prim . code-freevars)]
[code-ref code-ref-label (core-prim . code-ref)] [code-ref code-ref-label (core-prim . code-ref)]
@ -2026,7 +2054,7 @@
[else [else
(let ([e (car e*)]) (let ([e (car e*)])
(let-values ([(type value kwd) (syntax-type e r)]) (let-values ([(type value kwd) (syntax-type e r)])
(let ([kwd* (cons kwd kwd*)]) (let ([kwd* (cons-id kwd kwd*)])
(case type (case type
[(define) [(define)
(let-values ([(id rhs) (parse-define e)]) (let-values ([(id rhs) (parse-define e)])
@ -2111,7 +2139,7 @@
[else [else
(let ([e (car e*)]) (let ([e (car e*)])
(let-values ([(type value kwd) (syntax-type e r)]) (let-values ([(type value kwd) (syntax-type e r)])
(let ([kwd* (cons kwd kwd*)]) (let ([kwd* (cons-id kwd kwd*)])
(case type (case type
[(define) [(define)
(let-values ([(id rhs) (parse-define e)]) (let-values ([(id rhs) (parse-define e)])
@ -2127,23 +2155,29 @@
(cons lex lex*) (cons lex lex*)
(cons rhs rhs*) (cons rhs rhs*)
kwd*)))] kwd*)))]
[else [(begin)
(error 'chi-internal-module (syntax-match e ()
"cannot handle ~s" [(_ x* ...)
type)]))))])))))) (f (append x* (cdr e*)) r mr lhs* lex* rhs* kwd*)])]
[(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*))
r mr lhs* lex* rhs* kwd*)]
[else (return e* r mr lhs* lex* rhs* kwd*)]))))]))))))
(define chi-library-internal (define chi-library-internal
(lambda (e* r rib kwd*) (lambda (e* r rib kwd*)
(define return (define return
(lambda (init* r mr lhs* lex* rhs*) (lambda (init* module-init** r mr lhs* lex* rhs*)
(values init* r mr (reverse lhs*) (reverse lex*) (reverse rhs*)))) (let ([module-init* (apply append (reverse module-init**))])
(let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*]) (values (append module-init* init*)
r mr (reverse lhs*) (reverse lex*) (reverse rhs*)))))
(let f ([e* e*] [module-init** '()] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
(cond (cond
[(null? e*) (return e* r mr lhs* lex* rhs*)] [(null? e*) (return e* module-init** r mr lhs* lex* rhs*)]
[else [else
(let ([e (car e*)]) (let ([e (car e*)])
;(printf "chi ~s\n" e) ;(printf "chi ~s\n" e)
(let-values ([(type value kwd) (syntax-type e r)]) (let-values ([(type value kwd) (syntax-type e r)])
(let ([kwd* (cons kwd kwd*)]) (let ([kwd* (cons-id kwd kwd*)])
(case type (case type
[(define) [(define)
(let-values ([(id rhs) (parse-define e)]) (let-values ([(id rhs) (parse-define e)])
@ -2155,6 +2189,7 @@
[lab (gen-label id)]) [lab (gen-label id)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
(f (cdr e*) (f (cdr e*)
module-init**
(cons (cons lab (cons 'lexical lex)) r) (cons (cons lab (cons 'lexical lex)) r)
mr mr
(cons id lhs*) (cons lex lex*) (cons rhs rhs*) (cons id lhs*) (cons lex lex*) (cons rhs rhs*)
@ -2168,19 +2203,34 @@
(extend-rib! rib id lab) (extend-rib! rib id lab)
(let ([b (make-eval-transformer expanded-rhs)]) (let ([b (make-eval-transformer expanded-rhs)])
(f (cdr e*) (f (cdr e*)
module-init**
(cons (cons lab b) r) (cons (cons lab b) r)
(cons (cons lab b) mr) (cons (cons lab b) mr)
lhs* lex* rhs* kwd*)))))] lhs* lex* rhs* kwd*)))))]
[(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
(chi-internal-module e r mr kwd*)])
(for-each
(lambda (id lab) (extend-rib! rib id lab))
m-exp-id* m-exp-lab*)
(f (cdr e*)
(cons m-init* module-init**)
r mr
(append m-lhs* lhs*)
(append m-lex* lex*)
(append m-rhs* rhs*)
kwd*))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
(f (append x* (cdr e*)) r mr lhs* lex* rhs* (f (append x* (cdr e*)) module-init** r mr lhs* lex* rhs*
kwd*)])] kwd*)])]
[(macro) [(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*)) (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init**
r mr lhs* lex* rhs* kwd*)] r mr lhs* lex* rhs* kwd*)]
[else [else
(return e* r mr lhs* lex* rhs*)]))))])))) (return e* module-init** r mr lhs* lex* rhs*)]))))]))))
(define library-expander^ (define library-expander^
(lambda (e) (lambda (e)
(let-values ([(name exp* b*) (parse-library e)]) (let-values ([(name exp* b*) (parse-library e)])