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

* libfasl librarified

This commit is contained in:
Abdulaziz Ghuloum 2007-04-29 21:25:31 -04:00
parent 338265eab1
commit cb6971a438
3 changed files with 85 additions and 31 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.

32
src/libfasl.ss
View File

@ -29,7 +29,11 @@
;;; "T" : Thunk; followed by code. ;;; "T" : Thunk; followed by code.
(let ()
(library (ikarus fasl write)
(export)
(import (scheme))
(define write-fixnum (define write-fixnum
(lambda (x p) (lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x)) (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
@ -44,7 +48,7 @@
(write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p) (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p) (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p))) (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p)))
(define fasl-write-immediate (define fasl-write-immediate
(lambda (x p) (lambda (x p)
(cond (cond
@ -60,7 +64,7 @@
[(eof-object? x) (write-char #\E p)] [(eof-object? x) (write-char #\E p)]
[(eq? x (void)) (write-char #\U p)] [(eq? x (void)) (write-char #\U p)]
[else (error 'fasl-write "~s is not a fasl-writable immediate" x)]))) [else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
(define do-write (define do-write
(lambda (x p h m) (lambda (x p h m)
(cond (cond
@ -105,7 +109,7 @@
[(record? x) [(record? x)
(let ([rtd (record-type-descriptor x)]) (let ([rtd (record-type-descriptor x)])
(cond (cond
[(eq? rtd #%$base-rtd) [(eq? rtd $base-rtd)
;;; rtd record ;;; rtd record
(write-char #\R p) (write-char #\R p)
(let ([names (record-type-field-names x)] (let ([names (record-type-field-names x)]
@ -182,11 +186,11 @@
[(code? x) [(code? x)
(make-graph (code-reloc-vector x) h)] (make-graph (code-reloc-vector x) h)]
[(record? x) [(record? x)
(when (eq? x #%$base-rtd) (when (eq? x $base-rtd)
(error 'fasl-write "$base-rtd is not writable")) (error 'fasl-write "$base-rtd is not writable"))
(let ([rtd (record-type-descriptor x)]) (let ([rtd (record-type-descriptor x)])
(cond (cond
[(eq? rtd #%$base-rtd) [(eq? rtd $base-rtd)
;;; this is an rtd ;;; this is an rtd
(make-graph (record-type-name x) h) (make-graph (record-type-name x) h)
(make-graph (record-type-symbol x) h) (make-graph (record-type-symbol x) h)
@ -201,10 +205,10 @@
(record-type-field-names rtd))]))] (record-type-field-names rtd))]))]
[(procedure? x) [(procedure? x)
(let ([code ($closure-code x)]) (let ([code ($closure-code x)])
(unless (fxzero? ($code-freevars code)) (unless (fxzero? (code-freevars code))
(error 'fasl-write (error 'fasl-write
"Cannot write a non-thunk procedure; the one given has ~s free vars" "Cannot write a non-thunk procedure; the one given has ~s free vars"
($code-freevars code))) (code-freevars code)))
(make-graph code h))] (make-graph code h))]
[else (error 'fasl-write "~s is not fasl-writable" x)])])))) [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
(define do-fasl-write (define do-fasl-write
@ -228,7 +232,17 @@
(do-fasl-write x port)]))) (do-fasl-write x port)])))
(let ()
#!eof
#not working yet
(library (ikarus fasl read)
(export)
(import (scheme))
(define who 'fasl-read) (define who 'fasl-read)
(define (assert-eq? x y) (define (assert-eq? x y)
(unless (eq? x y) (unless (eq? x y)

84
src/syntax.ss
View File

@ -527,12 +527,12 @@
[or or-label (core-macro . or)] [or or-label (core-macro . or)]
[parameterize parameterize-label (core-macro . parameterize)] [parameterize parameterize-label (core-macro . parameterize)]
;;; prims ;;; prims
[void void-label (core-prim . void)] [void void-label (core-prim . void)]
[not not-label (core-prim . not)] [not not-label (core-prim . not)]
[boolean? boolean-label (core-prim . boolean?)] [boolean? boolean-label (core-prim . boolean?)]
[null? null?-label (core-prim . null?)] [null? null?-label (core-prim . null?)]
[procedure? procedure?-label (core-prim . procedure?)] [procedure? procedure?-label (core-prim . procedure?)]
[eof-object? eof-object?-label (core-prim . eof-object?)] [eof-object? eof-object?-label (core-prim . eof-object?)]
;;; comparison ;;; comparison
[eq? eq?-label (core-prim . eq?)] [eq? eq?-label (core-prim . eq?)]
[eqv? eqv?-label (core-prim . eqv?)] [eqv? eqv?-label (core-prim . eqv?)]
@ -559,6 +559,7 @@
[memv memv-label (core-prim . memv)] [memv memv-label (core-prim . memv)]
[member member-label (core-prim . member)] [member member-label (core-prim . member)]
;;; chars ;;; chars
[char? char?-label (core-prim . char?)]
[char=? char=?-label (core-prim . char=?)] [char=? char=?-label (core-prim . char=?)]
[integer->char integer->char-label (core-prim . integer->char)] [integer->char integer->char-label (core-prim . integer->char)]
[char->integer char->integer-label (core-prim . char->integer)] [char->integer char->integer-label (core-prim . char->integer)]
@ -596,6 +597,11 @@
[fxsub1 fxsub1-label (core-prim . fxsub1)] [fxsub1 fxsub1-label (core-prim . fxsub1)]
[fxquotient fxquotient-label (core-prim . fxquotient)] [fxquotient fxquotient-label (core-prim . fxquotient)]
[fxremainder fxremainder-label (core-prim . fxremainder)] [fxremainder fxremainder-label (core-prim . fxremainder)]
[fxsll fxsll-label (core-prim . fxsll)]
[fxsra fxsra-label (core-prim . fxsra)]
[fxlogand fxlogand-label (core-prim . fxlogand)]
[fxlogor fxlogor-label (core-prim . fxlogor)]
[fxlognot fxlognot-label (core-prim . fxlognot)]
;;; generic arithmetic ;;; generic arithmetic
[- minus-label (core-prim . -)] [- minus-label (core-prim . -)]
[* *-label (core-prim . *)] [* *-label (core-prim . *)]
@ -603,11 +609,13 @@
[quotient quotient-label (core-prim . quotient)] [quotient quotient-label (core-prim . quotient)]
;;; symbols/gensyms ;;; symbols/gensyms
[symbol? symbol?-label (core-prim . symbol?)] [symbol? symbol?-label (core-prim . symbol?)]
[gensym? gensym?-label (core-prim . gensym?)]
[gensym gensym-label (core-prim . gensym)] [gensym gensym-label (core-prim . gensym)]
[getprop getprop-label (core-prim . getprop)] [getprop getprop-label (core-prim . getprop)]
[putprop putprop-label (core-prim . putprop)] [putprop putprop-label (core-prim . putprop)]
[symbol->string symbol->string-label (core-prim . symbol->string)] [symbol->string symbol->string-label (core-prim . symbol->string)]
[$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)] [gensym->unique-string gensym->unique-string-label (core-prim . gensym->unique-string)]
[$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)]
;;; top-level ;;; top-level
[top-level-bound? top-level-bound-label (core-prim . top-level-bound?)] [top-level-bound? top-level-bound-label (core-prim . top-level-bound?)]
[top-level-value top-level-value-label (core-prim . top-level-value)] [top-level-value top-level-value-label (core-prim . top-level-value)]
@ -625,10 +633,15 @@
[write write-label (core-prim . write)] [write write-label (core-prim . write)]
[write-char write-char-label (core-prim . write-char)] [write-char write-char-label (core-prim . write-char)]
[read read-label (core-prim . read)] [read read-label (core-prim . read)]
[read-char read-char-label (core-prim . read-char)]
[newline newline-label (core-prim . newline)] [newline newline-label (core-prim . newline)]
[printf printf-label (core-prim . printf)] [printf printf-label (core-prim . printf)]
[format format-label (core-prim . format)] [format format-label (core-prim . format)]
[pretty-print pretty-print-label (core-prim . pretty-print)] [pretty-print pretty-print-label (core-prim . pretty-print)]
;;; hash tables
[make-hash-table make-hash-table-label (core-prim . make-hash-table)]
[get-hash-table get-hash-table-label (core-prim . get-hash-table)]
[put-hash-table! put-hash-table!-label (core-prim . put-hash-table!)]
;;; evaluation / control ;;; evaluation / control
[apply apply-label (core-prim . apply)] [apply apply-label (core-prim . apply)]
[values values-label (core-prim . values)] [values values-label (core-prim . values)]
@ -647,14 +660,35 @@
[load load-label (core-prim . load)] [load load-label (core-prim . load)]
[new-cafe new-cafe-label (core-prim . new-cafe)] [new-cafe new-cafe-label (core-prim . new-cafe)]
[command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)] [command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)]
;;; record/mid-level
[record? record?-label (core-prim . record?)]
[record-type-descriptor record-type-descriptor-label (core-prim . record-type-descriptor)]
[record-type-field-names record-type-field-names-label (core-prim . record-type-field-names)]
[record-type-symbol record-type-symbol-label (core-prim . record-type-symbol)]
[record-type-name record-type-name-label (core-prim . record-type-name)]
[record-field-accessor record-field-accessor-label (core-prim . record-field-accessor)]
[record-field-mutator record-field-mutator-label (core-prim . record-field-mutator)]
;;; records/low-level ;;; records/low-level
[$base-rtd $base-rtd-label (core-prim . $base-rtd)]
[$record-set! $record-set!-label (core-prim . $record-set!)] [$record-set! $record-set!-label (core-prim . $record-set!)]
[$record-ref $record-ref-label (core-prim . $record-ref)] [$record-ref $record-ref-label (core-prim . $record-ref)]
[$record $record-label (core-prim . $record)] [$record $record-label (core-prim . $record)]
[$record? $record?-label (core-prim . $record?)] [$record? $record?-label (core-prim . $record?)]
[$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)] [$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)]
;;; codes
[$closure-code $closure-code-label (core-prim . $closure-code)]
[code? code?-label (core-prim . code?)]
[code-reloc-vector code-reloc-vector-label (core-prim . code-reloc-vector)]
[code-size code-size-label (core-prim . code-size)]
[code-freevars code-freevars-label (core-prim . code-freevars)]
[code-ref code-ref-label (core-prim . code-ref)]
; [X X-label (core-prim . X)]
; [X X-label (core-prim . X)]
; [X X-label (core-prim . X)]
; [X X-label (core-prim . X)]
;;; misc ;;; misc
[primitive-set! primitive-set!-label (core-prim . primitive-set!)] [immediate? immediate?-label (core-prim . immediate?)]
[primitive-set! primitive-set!-label (core-prim . primitive-set!)]
[primitive-ref primitive-ref-label (core-prim . primitive-ref)] [primitive-ref primitive-ref-label (core-prim . primitive-ref)]
)) ))
(define make-scheme-rib (define make-scheme-rib
@ -1188,19 +1222,25 @@
(values (cons a a*) (cons b b*))))]))) (values (cons a a*) (cons b b*))))])))
(define chi-rhs* (define chi-rhs*
(lambda (rhs* r mr) (lambda (rhs* r mr)
(map (lambda (rhs) (define chi-rhs
(case (car rhs) (lambda (rhs)
[(defun) (case (car rhs)
(let ([x (cdr rhs)]) [(defun)
(let ([fmls (car x)] [body* (cdr x)]) (let ([x (cdr rhs)])
(let-values ([(fmls body) (let ([fmls (car x)] [body* (cdr x)])
(chi-lambda-clause fmls body* r mr)]) (let-values ([(fmls body)
(build-lambda no-source fmls body))))] (chi-lambda-clause fmls body* r mr)])
[(expr) (build-lambda no-source fmls body))))]
(let ([expr (cdr rhs)]) [(expr)
(chi-expr expr r mr))] (let ([expr (cdr rhs)])
[else (error 'chi-rhs "invalid rhs ~s" rhs)])) (chi-expr expr r mr))]
rhs*))) [else (error 'chi-rhs "invalid rhs ~s" rhs)])))
(let f ([ls rhs*])
(cond ;;; chi in order
[(null? ls) '()]
[else
(let ([a (chi-rhs (car ls))])
(cons a (f (cdr ls))))]))))
(define find-bound=? (define find-bound=?
(lambda (x lhs* rhs*) (lambda (x lhs* rhs*)
(cond (cond