- Added cp0! including:

- (optimize-level [0,1,2])  and  ikarus -O[0,1,2]
       where -O0 = no optimizations
             -O1 = using old optimizer
             -O2 = using the new cp0 optimizer
       defaults to -O1 for now.
   - (cp0-size-limit n) which is the limit of the residual size for
     each inlining attempt
   - (cp0-effort-limit n) which is the limit on the effort expended 
     for each inlining attempt
   
- Rewrote the syntax-match macro to make use of the same technology
  used in syntax-case itself resulting in reduced code size.

- Added (system-value <symbol>) which returns the system value.
  E.g., (system-value 'car) => #<procedure car>
  This is pretty much the same as 
    (eval <symbol> (environment '(ikarus)))
  except that it does not involve compiling the expression or 
  consulting the library/expander systems.

- Fixed the fasl loader to make it understand complex numbers.
This commit is contained in:
Abdulaziz Ghuloum 2008-06-28 02:25:44 -07:00
parent 7d9ed176ac
commit 45346ef865
20 changed files with 756 additions and 975 deletions

View File

@ -1,7 +1,10 @@
#!../src/ikarus -b ../scheme/ikarus.boot --r6rs-script
(import (ikarus))
(optimize-level 2)
;(cp0-effort-limit 1000)
;(cp0-size-limit 100)
;(debug-optimizer #t)
(define (run name)
(let ([proc (time-it (format "compile-~a" name)
(lambda ()

View File

@ -2,17 +2,17 @@
(import (ikarus))
;(define all-benchmarks
; '(ack array1 bibfreq boyer browse cat compiler conform cpstak ctak dderiv
; deriv destruc diviter divrec dynamic earley fft fib fibc fibfp
; fpsum gcbench gcold graphs lattice matrix maze mazefun mbrot
; nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
; pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
; slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2
; triangl wc))
(define all-benchmarks
'(cat tail wc slatex))
'(ack array1 bibfreq boyer browse cat compiler conform cpstak ctak dderiv
deriv destruc diviter divrec dynamic earley fft fib fibc fibfp
fpsum gcbench #|gcold|# graphs lattice matrix maze mazefun mbrot
nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2
triangl wc))
;(define all-benchmarks
; '(cat tail wc slatex))
(define cmd

Binary file not shown.

View File

@ -999,4 +999,9 @@
)
(library (ikarus system bytevectors)
(export $bytevector-u8-ref $bytevector-length $make-bytevector)
(import (ikarus))
(define $bytevector-u8-ref bytevector-u8-ref)
(define $bytevector-length bytevector-length)
(define $make-bytevector make-bytevector))

View File

@ -226,6 +226,11 @@
(err ($car c*))))))
(err c2)))))
(err c1))])))
)
(library (ikarus system chars)
(export $char->fixnum $fixnum->char)
(import (ikarus))
(define $char->fixnum char->integer)
(define $fixnum->char integer->char))

File diff suppressed because it is too large Load Diff

View File

@ -19,7 +19,7 @@
assembler-output scc-letrec optimize-cp
current-primitive-locations eval-core
compile-core-expr
cp0-effort-limit cp0-size-limit)
cp0-effort-limit cp0-size-limit optimize-level)
(import
(rnrs hashtables)
(ikarus system $fx)
@ -27,7 +27,7 @@
(only (ikarus system $codes) $code->closure)
(only (ikarus system $structs) $struct-ref $struct/rtd?)
(except (ikarus)
optimize-level
optimize-level debug-optimizer
fasl-write scc-letrec optimize-cp
compile-core-expr-to-port assembler-output
current-primitive-locations eval-core
@ -433,7 +433,7 @@
[else (cons (E x) ac)]))
(cons 'begin (f e0 (f e1 '()))))]
[(clambda-case info body)
`( label: ,(case-info-label info)
`( ; label: ,(case-info-label info)
,(E-args (case-info-proper info) (case-info-args info))
,(E body))]
[(clambda g cls* cp free)
@ -1100,34 +1100,6 @@
x)
#|FIXME:missing-optimizations
111 cadr
464 $record/rtd?
404 memq
249 map
114 not
451 car
224 syntax-error
248 $syntax-dispatch
237 pair?
125 length
165 $cdr
137 $car
805 $record-ref
181 fixnum?
328 null?
136 fx-
207 eq?
153 call-with-values
165 values
336 apply
384 cdr
898 cons
747 error
555 void
645 list
|#
;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
;;; also fx+, fx-
@ -1524,6 +1496,12 @@
(giveup)]
))
;;; $car $cdr $struct-ref $struct/rtd?
;;; expt + * - fx+ fxadd1 fxsub1
;;; cons cons* list vector
;;; length memq memv eq? eqv?
;;; not null? pair? fixnum? vector? string? char? symbol? eof-object?
;;; cadr void car cdr
(define (mk-mvcall p c)
(struct-case p
@ -1819,10 +1797,13 @@
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[else (error who "invalid value expression" (unparse x))]))
(let ([x (Value x)])
;;; since we messed up the references and assignments here, we
;;; redo them
(uncover-assigned/referenced x)))
(case (optimize-level)
[(1)
(let ([x (Value x)])
;;; since we messed up the references and assignments here, we
;;; redo them
(uncover-assigned/referenced x))]
[else x]))
(define (rewrite-assignments x)
@ -2998,9 +2979,6 @@
[else
(printf " ~s\n" x)]))
(define optimizer 'old)
(define (compile-core-expr->code p)
(let* ([p (recordize p)]
[p (parameterize ([open-mvcalls #f])
@ -3008,13 +2986,9 @@
[p (if (scc-letrec)
(optimize-letrec/scc p)
(optimize-letrec p))]
[p (if (eq? optimizer 'new)
(source-optimize p)
p)]
[p (source-optimize p)]
[p (uncover-assigned/referenced p)]
[p (if (eq? optimizer 'old)
(copy-propagate p)
p)]
[p (copy-propagate p)] ;;; old optimizer
[p (rewrite-assignments p)]
[p (sanitize-bindings p)]
[p (optimize-for-direct-jumps p)]

View File

@ -581,3 +581,30 @@
)
(library (ikarus fixnums unsafe)
(export $fxzero? $fxadd1 $fxsub1
$fx+ $fx* $fx- $fx= $fx< $fx<= $fx> $fx>=
$fxsll $fxsra $fxlogor $fxlogand $fxlognot)
(import (ikarus))
(define $fxzero? fxzero?)
(define $fxadd1 fxadd1)
(define $fxsub1 fxsub1)
(define $fx+ fx+)
(define $fx* fx*)
(define $fx- fx-)
(define $fx= fx=)
(define $fx< fx<)
(define $fx<= fx<=)
(define $fx> fx>)
(define $fx>= fx>=)
(define $fxsll fxsll)
(define $fxsra fxsra)
(define $fxlogor fxlogor)
(define $fxlogand fxlogand)
(define $fxlognot fxlognot))

View File

@ -74,6 +74,15 @@
(let f ([args (command-line-arguments)])
(cond
[(null? args) (values '() #f #f '())]
[(string=? (car args) "-O2")
(optimize-level 2)
(f (cdr args))]
[(string=? (car args) "-O1")
(optimize-level 1)
(f (cdr args))]
[(string=? (car args) "-O0")
(optimize-level 0)
(f (cdr args))]
[(string=? (car args) "--")
(values '() #f #f (cdr args))]
[(string=? (car args) "--script")

View File

@ -3699,3 +3699,8 @@
[else
(die 'imag-part "not a number" x)])))
)
(library (ikarus system flonums)
(export $fixnum->flonum)
(import (ikarus))
(define $fixnum->flonum fixnum->flonum))

View File

@ -102,3 +102,11 @@
[cdaddr $cdr $car $cdr $cdr]
[cadddr $car $cdr $cdr $cdr]
[cddddr $cdr $cdr $cdr $cdr]))
(library (ikarus system pairs)
(export $car $cdr)
(import (ikarus))
(define $car car)
(define $cdr cdr))

View File

@ -286,3 +286,13 @@
(display (rtd-name x) p)
(display " rtd>" p)))
)
(library (ikarus systems structs)
(export $struct-ref $struct/rtd?)
(import (ikarus))
(define $struct-ref struct-ref)
(define ($struct/rtd? x rtd)
(import (ikarus system $structs))
($struct/rtd? x rtd)))

View File

@ -14,19 +14,19 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus base symbols)
(library (ikarus.symbols)
(export gensym gensym? gensym->unique-string gensym-prefix
gensym-count print-gensym string->symbol symbol->string
getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value!
symbol-value symbol-bound? set-symbol-value!
reset-symbol-proc!)
reset-symbol-proc! system-value system-value-gensym)
(import
(ikarus system $symbols)
(ikarus system $pairs)
(ikarus system $fx)
(except (ikarus) gensym gensym? gensym->unique-string
gensym-prefix gensym-count print-gensym
gensym-prefix gensym-count print-gensym system-value
string->symbol symbol->string
getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value!
@ -223,5 +223,21 @@
(die 'print-gensym "not in #t|#f|pretty" x))
x)))
(define system-value-gensym (gensym))
(define (system-value x)
(unless (symbol? x)
(die 'system-value "not a symbol" x))
(cond
[(getprop x system-value-gensym) =>
(lambda (g)
(let ([v ($symbol-value g)])
(when ($unbound-object? v)
(die 'system-value "not a system symbol" x))
v))]
[else (die 'system-value "not a system symbol" x)]))
)

View File

@ -279,3 +279,11 @@
(f v ($fxadd1 i) n fill))))
)
(library (ikarus system vectors)
(export $vector-ref $vector-length)
(import (ikarus))
(define $vector-ref vector-ref)
(define $vector-length vector-length))

View File

@ -1 +1 @@
1521
1522

View File

@ -1,4 +1,4 @@
#!../src/ikarus -b ikarus.boot --r6rs-script
#!../src/ikarus -b ikarus.boot -O2 --r6rs-script
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
@ -17,7 +17,7 @@
;;; vim:syntax=scheme
(import (only (ikarus) import))
(import (except (ikarus)
assembler-output scc-letrec optimize-cp
assembler-output scc-letrec optimize-cp optimize-level
cp0-size-limit cp0-effort-limit))
(import (ikarus.compiler))
(import (except (psyntax system $bootstrap)
@ -25,6 +25,7 @@
current-primitive-locations
compile-core-expr-to-port))
(import (ikarus.compiler)) ; just for fun
(optimize-level 2)
(pretty-width 160)
((pretty-format 'fix) ((pretty-format 'letrec)))
@ -1311,6 +1312,7 @@
[void i $boot]
[gensym i symbols $boot]
[symbol-value i symbols $boot]
[system-value i]
[set-symbol-value! i symbols $boot]
[eval-core $boot]
[pretty-print i $boot]
@ -1432,6 +1434,7 @@
[ellipsis-map ]
[scc-letrec i]
[optimize-cp i]
[optimize-level i]
[cp0-size-limit i]
[cp0-effort-limit i]
))
@ -1589,16 +1592,19 @@
(let ([code `(library (ikarus primlocs)
(export) ;;; must be empty
(import
(only (ikarus.symbols) system-value-gensym)
(only (psyntax library-manager)
install-library)
(only (ikarus.compiler)
current-primitive-locations)
(ikarus))
(current-primitive-locations
(lambda (x)
(cond
[(assq x ',primlocs) => cdr]
[else #f])))
(let ([g system-value-gensym])
(for-each
(lambda (x) (putprop (car x) g (cdr x)))
',primlocs)
(let ([proc
(lambda (x) (getprop x g))])
(current-primitive-locations proc)))
,@(map build-library library-legend))])
(let-values ([(name code empty-subst empty-env)
(boot-library-expand code)])
@ -1699,6 +1705,7 @@
(debugf "\n")))
(close-output-port p)))))
;(print-missing-prims)
(printf "Happy Happy Joy Joy\n")

View File

@ -108,6 +108,19 @@
[(P x y) (prm '= (T x) (T y))]
[(E x y) (nop)])
(define (equable-constant? x)
(struct-case x
[(constant xv) (equable? xv)]
[else #f]))
(define-primop eqv? safe
[(P x y)
(if (or (equable-constant? x)
(equable-constant? y))
(prm '= (T x) (T y))
(interrupt))]
[(E x y) (nop)])
(define-primop null? safe
[(P x) (prm '= (T x) (K nil))]
[(E x) (nop)])
@ -201,6 +214,44 @@
[else (interrupt)])]
[(E x ls) (nop)])
(define-primop memq safe
[(P x ls) (cogen-pred-$memq x ls)]
[(V x ls) (cogen-value-$memq x ls)]
[(E x ls)
(struct-case ls
[(constant ls)
(cond
[(list? ls) (nop)]
[else (interrupt)])]
[else (interrupt)])])
(define (equable? x)
(or (fixnum? x) (not (number? x))))
(define-primop memv safe
[(V x ls)
(struct-case ls
[(constant lsv)
(cond
[(and (list? lsv) (andmap equable? lsv))
(cogen-value-$memq x ls)]
[else (interrupt)])]
[else (interrupt)])]
[(P x ls)
(struct-case ls
[(constant lsv)
(cond
[(and (list? lsv) (andmap equable? lsv))
(cogen-pred-$memq x ls)]
[else (interrupt)])]
[else (interrupt)])]
[(E x ls)
(struct-case ls
[(constant lsv)
(cond
[(list? lsv) (nop)]
[else (interrupt)])]
[else (interrupt)])])
/section)

View File

@ -764,118 +764,83 @@
;;; not to special pattern variables.
(define-syntax syntax-match
(lambda (ctx)
(define dots?
(lambda (x)
(and (sys.identifier? x)
(sys.free-identifier=? x (syntax (... ...))))))
(define free-identifier-member?
(lambda (x ls)
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
(define (parse-clause lits cls)
(define (parse-pat pat)
(syntax-case pat ()
(id (sys.identifier? (syntax id))
(cond
((free-identifier-member? (syntax id) lits)
(values '()
(syntax
(lambda (x)
(and (id? x)
(free-id=? x (scheme-stx 'id))
'())))))
((sys.free-identifier=? (syntax id) (syntax _))
(values '() (syntax (lambda (x) '()))))
(else
(values (list (syntax id)) (syntax (lambda (x) (list x)))))))
((pat dots) (dots? (syntax dots))
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars) (decon decon))
(values pvars
(syntax (letrec ((f (lambda (x)
(cond
((syntax-pair? x)
(let ((cars/f (decon (syntax-car x))))
(and cars/f
(let ((cdrs/f (f (syntax-cdr x))))
(and cdrs/f
(map cons cars/f cdrs/f))))))
((syntax-null? x)
(list (begin 'v* '()) ...))
(else #f)))))
f))))))
((pat dots . last) (dots? (syntax dots))
(let-values (((p1 d1) (parse-pat (syntax pat)))
((p2 d2) (parse-pat (syntax last))))
(with-syntax (((v* ...) (append p1 p2))
((v1* ...) p1)
((v2* ...) p2)
(d1 d1) (d2 d2))
(values (append p1 p2)
(syntax (letrec ((f (lambda (x)
(cond
((syntax-pair? x)
(let ((cars/f (d1 (syntax-car x))))
(and cars/f
(let ((d/f (f (syntax-cdr x))))
(and d/f
(cons (map cons cars/f (car d/f))
(cdr d/f)))))))
(else
(let ((d (d2 x)))
(and d
(cons (list (begin 'v1* '()) ...)
d))))))))
(lambda (x)
(let ((x (f x)))
(and x (append (car x) (cdr x)))))))))))
((pat1 . pat2)
(let-values (((p1 d1) (parse-pat (syntax pat1)))
((p2 d2) (parse-pat (syntax pat2))))
(with-syntax ((d1 d1) (d2 d2))
(values (append p1 p2)
(syntax (lambda (x)
(and (syntax-pair? x)
(let ((q (d1 (syntax-car x))))
(and q
(let ((r (d2 (syntax-cdr x))))
(and r (append q r))))))))))))
(#(pats ...)
(let-values (((pvars d) (parse-pat (syntax (pats ...)))))
(with-syntax ((d d))
(values pvars
(syntax (lambda (x)
(and (syntax-vector? x)
(d (syntax-vector->list x)))))))))
(datum
(values '()
(syntax (lambda (x)
(and (equal? (stx->datum x) 'datum) '())))))))
(syntax-case cls ()
((pat body)
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars))
(values decon
(syntax (lambda (v* ...) #t))
(syntax (lambda (v* ...) body))))))
((pat guard body)
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars))
(values decon
(syntax (lambda (v* ...) guard))
(syntax (lambda (v* ...) body))))))))
(define convert-pattern
; returns syntax-dispatch pattern & ids
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
(if (null? p*)
(values '() ids)
(let-values (((y ids) (cvt* (cdr p*) n ids)))
(let-values (((x ids) (cvt (car p*) n ids)))
(values (cons x y) ids))))))
(define free-identifier-member?
(lambda (x ls)
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
(define (bound-id-member? x ls)
(and (pair? ls)
(or (sys.bound-identifier=? x (car ls))
(bound-id-member? x (cdr ls)))))
(define ellipsis?
(lambda (x)
(and (sys.identifier? x)
(sys.free-identifier=? x (syntax (... ...))))))
(define cvt
(lambda (p n ids)
(syntax-case p ()
(id (sys.identifier? #'id)
(cond
((bound-id-member? p keys)
(values `#(scheme-id ,(sys.syntax->datum p)) ids))
((sys.free-identifier=? p #'_)
(values '_ ids))
(else (values 'any (cons (cons p n) ids)))))
((p dots) (ellipsis? #'dots)
(let-values (((p ids) (cvt #'p (+ n 1) ids)))
(values
(if (eq? p 'any) 'each-any `#(each ,p))
ids)))
((x dots ys ... . z) (ellipsis? #'dots)
(let-values (((z ids) (cvt #'z n ids)))
(let-values (((ys ids) (cvt* #'(ys ...) n ids)))
(let-values (((x ids) (cvt #'x (+ n 1) ids)))
(values `#(each+ ,x ,(reverse ys) ,z) ids)))))
((x . y)
(let-values (((y ids) (cvt #'y n ids)))
(let-values (((x ids) (cvt #'x n ids)))
(values (cons x y) ids))))
(() (values '() ids))
(#(p ...)
(let-values (((p ids) (cvt #'(p ...) n ids)))
(values `#(vector ,p) ids)))
(datum
(values `#(atom ,(sys.syntax->datum #'datum)) ids)))))
(cvt pattern 0 '())))
(syntax-case ctx ()
((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...)))
(syntax (stx-error expr "invalid syntax")))
((_ expr (lits ...) cls cls* ...) (for-all sys.identifier?
(syntax (lits ...)))
(let-values (((decon guard body)
(parse-clause (syntax (lits ...)) (syntax cls))))
(with-syntax ((decon decon) (guard guard) (body body))
(syntax (let ((t expr))
(let ((ls/false (decon t)))
(if (and ls/false (apply guard ls/false))
(apply body ls/false)
(syntax-match t (lits ...) cls* ...)))))))))))
((_ expr (lits ...) [pat fender body] cls* ...)
(for-all sys.identifier? (syntax (lits ...)))
(let-values ([(pattern ids/levels) (convert-pattern #'pat #'(lits ...))])
(with-syntax ([pattern (sys.datum->syntax #'here pattern)]
[([ids . levels] ...) ids/levels])
#'(let ([t expr])
(let ([ls/false (syntax-dispatch t 'pattern)])
(if (and ls/false (apply (lambda (ids ...) fender) ls/false))
(apply (lambda (ids ...) body) ls/false)
(syntax-match t (lits ...) cls* ...)))))))
((_ expr (lits ...) [pat body] cls* ...)
(for-all sys.identifier? (syntax (lits ...)))
(let-values ([(pattern ids/levels) (convert-pattern #'pat #'(lits ...))])
(with-syntax ([pattern (sys.datum->syntax #'here pattern)]
[([ids . levels] ...) ids/levels])
#'(let ([t expr])
(let ([ls/false (syntax-dispatch t 'pattern)])
(if ls/false
(apply (lambda (ids ...) body) ls/false)
(syntax-match t (lits ...) cls* ...)))))))
((_ expr (lits ...) [pat body] cls* ...)
#'(syntax-match expr (lits ...) [pat #t body] cls* ...)))))
(define parse-define
@ -906,7 +871,7 @@
(let* ((subst
(library-subst
(find-library-by-name '(psyntax system $all))))
(stx (mkstx sym top-mark* '() '()))
(stx (make-stx sym top-mark* '() '()))
(stx
(cond
((assq sym subst) =>
@ -2157,7 +2122,7 @@
(lambda (e p)
(define stx^
(lambda (e m* s* ae*)
(if (and (null? m*) (null? s*))
(if (and (null? m*) (null? s*) (null? ae*))
e
(mkstx e m* s* ae*))))
(define match-each
@ -2233,6 +2198,7 @@
(reverse (vector-ref p 2))
(match-empty (vector-ref p 3) r))))
((free-id atom) r)
((scheme-id atom) r)
((vector) (match-empty (vector-ref p 1) r))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define combine
@ -2262,6 +2228,12 @@
(top-marked? m*)
(free-id=? (stx^ e m* s* ae*) (vector-ref p 1))
r))
((scheme-id)
(and (symbol? e)
(top-marked? m*)
(free-id=? (stx^ e m* s* ae*)
(scheme-stx (vector-ref p 1)))
r))
((each+)
(let-values (((xr* y-pat r)
(match-each+ e (vector-ref p 1)
@ -2992,7 +2964,7 @@
(vector-map
(lambda (x)
(or (id->label
(mkstx (id->sym x) (stx-mark* x)
(make-stx (id->sym x) (stx-mark* x)
(list rib)
'()))
(stx-error x "cannot find module export")))
@ -3503,7 +3475,7 @@
(parse-import-spec* imp*)))
(let ((rib (make-top-rib subst-names subst-labels)))
(let ((b* (map (lambda (x)
(mkstx x top-mark* (list rib) '()))
(make-stx x top-mark* (list rib) '()))
b*))
(rtc (make-collector))
(vtc (make-collector)))
@ -3628,7 +3600,7 @@
(cond
[(env? env)
(let ((rib (make-top-rib (env-names env) (env-labels env))))
(let ((x (mkstx x top-mark* (list rib) '()))
(let ((x (make-stx x top-mark* (list rib) '()))
(itc (env-itc env))
(rtc (make-collector))
(vtc (make-collector)))
@ -3741,7 +3713,7 @@
(define (make-export-subst int* ext* rib)
(map
(lambda (int ext)
(let* ((id (mkstx int top-mark* (list rib) '()))
(let* ((id (make-stx int top-mark* (list rib) '()))
(label (id->label id)))
(unless label
(stx-error id "cannot export unbound identifier"))

View File

@ -557,6 +557,28 @@ static ikptr do_read(ikpcb* pcb, fasl_port* p){
}
return x;
}
else if(c == 'i'){
ikptr real = do_read(pcb, p);
ikptr imag = do_read(pcb, p);
ikptr x;
if ((tagof(real) == vector_tag)
&& (ref(real, -vector_tag) == flonum_tag)){
x = ik_unsafe_alloc(pcb, cflonum_size);
ref(x, 0) = cflonum_tag;;
ref(x, disp_cflonum_real) = real;
ref(x, disp_cflonum_imag) = imag;
} else {
x = ik_unsafe_alloc(pcb, compnum_size);
ref(x, 0) = compnum_tag;
ref(x, disp_compnum_real) = real;
ref(x, disp_compnum_imag) = imag;
}
x += vector_tag;
if(put_mark_index){
p->marks[put_mark_index] = x;
}
return x;
}
else {
fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c);
exit(-1);