* added code? to the compiler.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-06 22:48:10 -04:00
parent 1703ff38f8
commit d58f15b14c
7 changed files with 27 additions and 60 deletions

Binary file not shown.

View File

@ -1,12 +1,13 @@
(library (ikarus code-objects)
(export
make-code code? code-reloc-vector code-freevars
code-size code-ref code-set! set-code-reloc-vector!)
make-code code-reloc-vector code-freevars
code-size code-ref code-set! set-code-reloc-vector!
code->thunk)
(import
(ikarus system $fx)
(ikarus system $codes)
(except (ikarus) make-code code? code-reloc-vector code-freevars
(except (ikarus) make-code code-reloc-vector code-freevars
code-size code-ref code-set! set-code-reloc-vector!))
(define make-code
@ -17,9 +18,6 @@
(error 'make-code "~s is not a valid number of free vars" freevars))
(foreign-call "ikrt_make_code" code-size freevars '#())))
(define code?
(lambda (x) ($code? x)))
(define code-reloc-vector
(lambda (x)
(unless ($code? x) (error 'code-reloc-vector "~s is not a code" x))
@ -64,5 +62,14 @@
(unless (vector? v)
(error 'set-code-reloc-vector! "~s is not a vector" v))
(foreign-call "ikrt_set_code_reloc_vector" x v)))
(define code->thunk
(lambda (x)
(unless ($code? x)
(error 'code->thunk "~s is not a a code object" x))
(unless ($fxzero? ($code-freevars x))
(error 'code->thunk "~s has free variables" x))
($code->closure x)))
)

View File

@ -190,6 +190,7 @@
;;; asm
;;;
[$code? 1 pred]
[code? 1 pred]
[$code-size 1 value]
[$code-reloc-vector 1 value]
[$code-freevars 1 value]
@ -2017,7 +2018,7 @@
(case op
[(fixnum? flonum? bignum? immediate? boolean? char? vector? string? procedure?
null? pair? not cons eq? vector symbol? error eof-object eof-object?
void base-rtd $unbound-object? $code? $forward-ptr? bwp-object?
void base-rtd $unbound-object? $code? code? $forward-ptr? bwp-object?
pointer-value top-level-value car cdr list* list $record
port? input-port? output-port?
$make-port/input $make-port/output $make-port/both
@ -3327,7 +3328,7 @@
[(not) (Pred (car rand*) Lf Lt ac)]
[(eof-object?) (type-pred #f eof rand* Lt Lf ac)]
[(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)]
[($code?)
[($code? code?)
(indirect-type-pred vector-mask vector-tag #f code-tag
rand* Lt Lf ac)]
[($fxzero?) (type-pred #f 0 rand* Lt Lf ac)]
@ -4092,7 +4093,8 @@
[(fixnum? bignum? flonum? immediate? $fxzero? boolean? char? pair?
vector? string? symbol?
procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
$char= $char< $char<= $char> $char>= $unbound-object? $code?
$char= $char< $char<= $char> $char>= $unbound-object? $code?
code?
$record? $record/rtd? bwp-object? port? input-port? output-port?)
(do-pred->value-prim op arg* ac)]
[($code->closure)

View File

@ -35,6 +35,7 @@
(import
(ikarus system $codes)
(ikarus system $records)
(ikarus code-objects)
(except (ikarus) fasl-write))
(define write-fixnum

View File

@ -1,47 +1,10 @@
;;;
;;; assuming the existence of a code manager, this file defines an assember
;;; that takes lists of assembly code and produces a list of code objects
;;;
;;; add
;;; and
;;; cmp
;;; call
;;; cltd
;;; idiv
;;; imull
;;; ja
;;; jae
;;; jb
;;; jbe
;;; je
;;; jg
;;; jge
;;; jl
;;; jle
;;; jne
;;; jmp
;;; movb
;;; movl
;;; negl
;;; notl
;;; orl
;;; popl
;;; pushl
;;; ret
;;; sall
;;; sarl
;;; shrl
;;; sete
;;; setg
(library (ikarus intel-assembler)
(export assemble-sources)
(import
(ikarus)
(ikarus system $codes)
(ikarus code-objects)
(ikarus system $pairs))
(define fold
@ -894,7 +857,7 @@
(error 'whack-reloc
"cannot create a thunk pointing at ~s"
idx))
(let ([thunk ($code->closure code)])
(let ([thunk (code->thunk code)])
(set-cdr! (cdr p) (list thunk))
thunk))]
[else (caddr p)])))]

View File

@ -4,14 +4,14 @@
(export fixnum? flonum? bignum? number? complex? real? rational?
integer? exact? eof-object? bwp-object? immediate?
boolean? char? vector? string? procedure? null? pair?
symbol? not weak-pair? eq? eqv? equal?)
symbol? code? not weak-pair? eq? eqv? equal?)
(import
(except (ikarus) fixnum? flonum? bignum? number? complex? real?
rational? integer? exact? eof-object? bwp-object?
immediate? boolean? char? vector? string? procedure?
null? pair? weak-pair? symbol? not eq? eqv? equal?
null? pair? weak-pair? symbol? code? not eq? eqv? equal?
port? input-port? output-port?)
(ikarus system $fx)
(ikarus system $pairs)
@ -20,7 +20,7 @@
(ikarus system $vectors)
(rename (only (ikarus) fixnum? flonum? bignum? eof-object?
bwp-object? immediate? boolean? char? vector? string?
procedure? null? pair? symbol? eq?
procedure? null? pair? symbol? code? eq?
port? input-port? output-port?)
(fixnum? sys:fixnum?)
(flonum? sys:flonum?)
@ -36,6 +36,7 @@
(null? sys:null?)
(pair? sys:pair?)
(symbol? sys:symbol?)
(code? sys:code?)
(eq? sys:eq?)
(port? sys:port?)
(input-port? sys:input-port?)
@ -99,7 +100,7 @@
(define null? (lambda (x) (sys:null? x)))
(define pair? (lambda (x) (sys:pair? x)))
(define symbol? (lambda (x) (sys:symbol? x)))
(define code? (lambda (x) (sys:code? x)))
(define weak-pair?

View File

@ -52,8 +52,8 @@
"ikarus.writer.ss"
"ikarus.reader.ss"
"ikarus.code-objects.ss"
"ikarus.trace.ss"
"ikarus.intel-assembler.ss"
"ikarus.trace.ss"
"ikarus.fasl.ss"
"ikarus.compiler.ss"
"ikarus.library-manager.ss"
@ -394,13 +394,6 @@
[generate-temporaries i]
[free-identifier=? i]
[code? i]
[make-code i]
[code-reloc-vector i]
[set-code-reloc-vector! i]
[code-size i]
[code-freevars i]
[code-ref i]
[code-set! i]
[immediate? i]
[pointer-value i]