* added code? to the compiler.
This commit is contained in:
parent
1703ff38f8
commit
d58f15b14c
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -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)))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -35,6 +35,7 @@
|
|||
(import
|
||||
(ikarus system $codes)
|
||||
(ikarus system $records)
|
||||
(ikarus code-objects)
|
||||
(except (ikarus) fasl-write))
|
||||
|
||||
(define write-fixnum
|
||||
|
|
|
@ -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)])))]
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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]
|
||||
|
||||
|
|
Loading…
Reference in New Issue