diff --git a/src/ikarus.boot b/src/ikarus.boot index 2b8b11f..7627e11 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.code-objects.ss b/src/ikarus.code-objects.ss index a259720..ea75a93 100644 --- a/src/ikarus.code-objects.ss +++ b/src/ikarus.code-objects.ss @@ -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))) + ) diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 4320745..e5e53c7 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -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) diff --git a/src/ikarus.fasl.ss b/src/ikarus.fasl.ss index bb6025b..1a1f49b 100644 --- a/src/ikarus.fasl.ss +++ b/src/ikarus.fasl.ss @@ -35,6 +35,7 @@ (import (ikarus system $codes) (ikarus system $records) + (ikarus code-objects) (except (ikarus) fasl-write)) (define write-fixnum diff --git a/src/ikarus.intel-assembler.ss b/src/ikarus.intel-assembler.ss index f627a65..fa4231d 100644 --- a/src/ikarus.intel-assembler.ss +++ b/src/ikarus.intel-assembler.ss @@ -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)])))] diff --git a/src/ikarus.predicates.ss b/src/ikarus.predicates.ss index 25c367b..d671735 100644 --- a/src/ikarus.predicates.ss +++ b/src/ikarus.predicates.ss @@ -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? diff --git a/src/makefile.ss b/src/makefile.ss index 9bd096d..fcb7ece 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -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]