diff --git a/src/ikarus.boot b/src/ikarus.boot index e467ca6..054c6ad 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.chars.ss b/src/ikarus.chars.ss index edcbf17..d2e3cf3 100644 --- a/src/ikarus.chars.ss +++ b/src/ikarus.chars.ss @@ -1,15 +1,9 @@ (library (ikarus chars) - (export char=? char? char>=? ;char-whitespace? - char->integer integer->char - ;char-alphabetic? - char-downcase) + (export char=? char? char>=? char->integer integer->char) (import (except (ikarus) - char=? char? char>=? - integer->char char->integer - ;char-whitespace? char-alphabetic? - char-downcase) + char=? char? char>=? integer->char char->integer) (ikarus system $pairs) (ikarus system $chars) (ikarus system $fx)) @@ -219,37 +213,4 @@ (err c1))]))) - ;;; XXX (define char-whitespace? - ;;; XXX (lambda (c) - ;;; XXX (cond - ;;; XXX [(memq c '(#\space #\tab #\newline #\return)) #t] - ;;; XXX [(char? c) #f] - ;;; XXX [else - ;;; XXX (error 'char-whitespace? "~s is not a character" c)]))) - - ;;; XXX (define char-alphabetic? - ;;; XXX (lambda (c) - ;;; XXX (cond - ;;; XXX [(char? c) - ;;; XXX (cond - ;;; XXX [($char<= #\a c) ($char<= c #\z)] - ;;; XXX [($char<= #\A c) ($char<= c #\Z)] - ;;; XXX [else #f])] - ;;; XXX [else - ;;; XXX (error 'char-alphabetic? "~s is not a character" c)]))) - - (define char-downcase - (lambda (c) - (cond - [(char? c) - (cond - [(and ($char<= #\A c) ($char<= c #\Z)) - ($fixnum->char - ($fx+ ($char->fixnum c) - ($fx- ($char->fixnum #\a) - ($char->fixnum #\A))))] - [else c])] - [else - (error 'char-downcase "~s is not a character" c)]))) - ) diff --git a/src/ikarus.compiler.altcogen.ss b/src/ikarus.compiler.altcogen.ss index d8d3afc..bf6b9c7 100644 --- a/src/ikarus.compiler.altcogen.ss +++ b/src/ikarus.compiler.altcogen.ss @@ -32,18 +32,18 @@ (error who "invalid gensym ~s" x))) ;;; (define (check-label x) - (record-case x + (struct-case x [(code-loc label) (check-gensym label)] [else (error who "invalid label ~s" x)])) ;;; (define (check-var x) - (record-case x + (struct-case x [(var) (void)] [else (error who "invalid var ~s" x)])) ;;; (define (check-closure x) - (record-case x + (struct-case x [(closure label free*) (check-label label) (for-each check-var free*)] @@ -51,7 +51,7 @@ ;;; (define (mkfuncall op arg*) (import primops) - (record-case op + (struct-case op [(primref name) (cond [(primop? name) @@ -60,7 +60,7 @@ [else (make-funcall op arg*)])) ;;; (define (Expr x) - (record-case x + (struct-case x [(constant) x] [(var) x] [(primref) x] @@ -84,19 +84,19 @@ [else (error who "invalid expr ~s" x)])) ;;; (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Expr body))] [else (error who "invalid clambda-case ~s" x)])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) free* name)] [else (error who "invalid clambda ~s" x)])) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) (Expr body))] [else (error who "invalid program ~s" x)])) @@ -120,12 +120,12 @@ [else (f (cdr free*) (fxadd1 i))]))) (define (do-fix lhs* rhs* body) (define (handle-closure x) - (record-case x + (struct-case x [(closure code free*) (make-closure code (map Var free*))])) (make-fix lhs* (map handle-closure rhs*) body)) (define (Expr x) - (record-case x + (struct-case x [(constant) x] [(var) (Var x)] [(primref) x] @@ -155,9 +155,9 @@ ;;; (define (ClambdaCase free*) (lambda (x) - (record-case x + (struct-case x [(clambda-case info body) - (record-case info + (struct-case info [(case-info label args proper) (let ([cp (unique-var 'cp)]) (make-clambda-case @@ -166,14 +166,14 @@ [else (error who "invalid clambda-case ~s" x)]))) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map (ClambdaCase free*) case*) free* name)] [else (error who "invalid clambda ~s" x)])) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) ((Expr #f '()) body))] [else (error who "invalid program ~s" x)])) @@ -199,15 +199,15 @@ (make-primcall '$do-event '()) x)) (define (CaseExpr x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Tail body))])) (define (CodeExpr x) - (record-case x + (struct-case x [(clambda L cases free name) (make-clambda L (map CaseExpr cases) free name)])) (define (CodesExpr x) - (record-case x + (struct-case x [(codes list body) (make-codes (map CodeExpr list) (Tail body))])) (CodesExpr x)) @@ -229,12 +229,12 @@ x)) (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Main body))])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) free* name)])) ;;; @@ -244,7 +244,7 @@ x)) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) (Main body))])) ;;; @@ -288,7 +288,7 @@ (k (cons a d))))))])) ;;; (define (S x k) - (record-case x + (struct-case x [(bind lhs* rhs* body) (do-bind lhs* rhs* (S body k))] [(seq e0 e1) @@ -380,7 +380,7 @@ (list size))))) ;;; impose value (define (V d x) - (record-case x + (struct-case x [(constant) (make-set d x)] [(var) (cond @@ -486,7 +486,7 @@ (make-primcall 'return (list return-value-register)))))) ;;; impose effect (define (E x) - (record-case x + (struct-case x [(seq e0 e1) (make-seq (E e0) (E e1))] [(conditional e0 e1 e2) (make-conditional (P e0) (E e1) (E e2))] @@ -520,7 +520,7 @@ [else (error who "invalid effect ~s" x)])) ;;; impose pred (define (P x) - (record-case x + (struct-case x [(constant) x] [(seq e0 e1) (make-seq (E e0) (P e1))] [(conditional e0 e1 e2) @@ -585,7 +585,7 @@ (f (cdr args) (cdr locs) (cons t targs) (cons (car locs) tlocs))))])))) (define (Tail x) - (record-case x + (struct-case x [(constant) (VT x)] [(var) (VT x)] [(primcall op rands) @@ -661,9 +661,9 @@ fargs flocs))]))) ;;; (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) - (record-case info + (struct-case info [(case-info label args proper) (let-values ([(rargs rlocs fargs flocs) (partition-formals args)]) @@ -681,7 +681,7 @@ (make-locals locals body))))])])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) free* name)])) ;;; @@ -691,7 +691,7 @@ (make-locals locals x))) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) (Main body))])) ;;; @@ -703,7 +703,7 @@ empty-set? set->list list->set) - (define-record set (v)) + (define-struct set (v)) (define (make-empty-set) (make-set '())) (define (set-member? x s) @@ -983,7 +983,7 @@ delete-node!) (import ListySet) ;;; - (define-record graph (ls)) + (define-struct graph (ls)) ;;; (define (empty-graph) (make-graph '())) ;;; @@ -1051,7 +1051,7 @@ delete-node!) (import IntegerSet) ;;; - (define-record graph (ls)) + (define-struct graph (ls)) ;;; (define (empty-graph) (make-graph '())) ;;; @@ -1262,7 +1262,7 @@ (let-values ([(vs rs fs ns) (R (car ls) vs rs fs ns)]) (R* (cdr ls) vs rs fs ns))])) (define (E x vs rs fs ns) - (record-case x + (struct-case x [(seq e0 e1) (let-values ([(vs rs fs ns) (E e1 vs rs fs ns)]) (E e0 vs rs fs ns))] @@ -1488,7 +1488,7 @@ (define (P x vst rst fst nst vsf rsf fsf nsf vsu rsu fsu nsu) - (record-case x + (struct-case x [(seq e0 e1) (let-values ([(vs rs fs ns) (P e1 vst rst fst nst @@ -1529,7 +1529,7 @@ vsu rsu fsu nsu)))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) - (record-case x + (struct-case x [(seq e0 e1) (let-values ([(vs rs fs ns) (T e1)]) (E e0 vs rs fs ns))] @@ -1609,7 +1609,7 @@ (or (assign-move x) (assign-any)))) (define (NFE idx mask x) - (record-case x + (struct-case x [(seq e0 e1) (let ([e0 (E e0)]) (make-seq e0 (NFE idx mask e1)))] @@ -1642,7 +1642,7 @@ (make-disp (R (disp-s0 x)) (R (disp-s1 x)))] [else (error who "invalid R ~s" (unparse x))])) (define (E x) - (record-case x + (struct-case x [(seq e0 e1) (let ([e0 (E e0)]) (make-seq e0 (E e1)))] @@ -1767,7 +1767,7 @@ (make-shortcut (E body) (E handler))] [else (error who "invalid effect ~s" (unparse x))])) (define (P x) - (record-case x + (struct-case x [(seq e0 e1) (let ([e0 (E e0)]) (make-seq e0 (P e1)))] @@ -1779,7 +1779,7 @@ (make-shortcut (P body) (P handler))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) - (record-case x + (struct-case x [(seq e0 e1) (let ([e0 (E e0)]) (make-seq e0 (T e1)))] @@ -1792,7 +1792,7 @@ (T x)) ;;; (define (Main x) - (record-case x + (struct-case x [(locals vars body) (init-vars! vars) (let ([varvec (list->vector vars)]) @@ -1809,17 +1809,17 @@ [else (error 'assign-frame-sizes "invalid main ~s" x)])) ;;; (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Main body))])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) free* name)])) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) (Main body))])) ;;; @@ -1847,7 +1847,7 @@ [(null? ls) (make-empty-set)] [else (set-union (R (car ls)) (R* (cdr ls)))])) (define (R x) - (record-case x + (struct-case x [(constant) (make-empty-set)] [(var) (list->set (list x))] [(disp s0 s1) (set-union (R s0) (R s1))] @@ -1862,7 +1862,7 @@ [else (error who "invalid R ~s" x)])])) ;;; build effect (define (E x s) - (record-case x + (struct-case x [(asm-instr op d v) (case op [(move) @@ -1929,7 +1929,7 @@ (E body s)))] [else (error who "invalid effect ~s" (unparse x))])) (define (P x st sf su) - (record-case x + (struct-case x [(constant c) (if c st sf)] [(seq e0 e1) (E e0 (P e1 st sf su))] @@ -1944,7 +1944,7 @@ (P body st sf su)))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) - (record-case x + (struct-case x [(conditional e0 e1 e2) (let ([s1 (T e1)] [s2 (T e2)]) (P e0 s1 s2 (set-union s1 s2)))] @@ -2028,30 +2028,30 @@ [(assq x env) => cdr] [else x])) (define (Rhs x) - (record-case x + (struct-case x [(var) (Var x)] [(primcall op rand*) (make-primcall op (map Rand rand*))] [else x])) (define (Rand x) - (record-case x + (struct-case x [(var) (Var x)] [else x])) (define (Lhs x) - (record-case x + (struct-case x [(var) (Var x)] [(nfv confs loc) (or loc (error who "LHS not set ~s" x))] [else x])) (define (D x) - (record-case x + (struct-case x [(constant) x] [(var) (Var x)] [(fvar) x] [else (if (symbol? x) x (error who "invalid D ~s" x))])) (define (R x) - (record-case x + (struct-case x [(constant) x] [(var) (Var x)] [(fvar) x] @@ -2062,7 +2062,7 @@ (if (symbol? x) x (error who "invalid R ~s" x))])) ;;; substitute effect (define (E x) - (record-case x + (struct-case x [(seq e0 e1) (make-seq (E e0) (E e1))] [(conditional e0 e1 e2) (make-conditional (P e0) (E e1) (E e2))] @@ -2075,7 +2075,7 @@ (make-shortcut (E body) (E handler))] [else (error who "invalid effect ~s" (unparse x))])) (define (P x) - (record-case x + (struct-case x [(constant) x] [(asm-instr op x v) (make-asm-instr op (R x) (R v))] @@ -2086,7 +2086,7 @@ (make-shortcut (P body) (P handler))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) - (record-case x + (struct-case x [(primcall op rands) x] [(conditional e0 e1 e2) (make-conditional (P e0) (T e1) (T e2))] @@ -2141,7 +2141,7 @@ (or (disp? x) (fvar? x))) ;;; unspillable effect (define (E x) - (record-case x + (struct-case x [(seq e0 e1) (make-seq (E e0) (E e1))] [(conditional e0 e1 e2) (make-conditional (P e0) (E e1) (E e2))] @@ -2252,7 +2252,7 @@ (make-shortcut body (E handler)))] [else (error who "invalid effect ~s" (unparse x))])) (define (P x) - (record-case x + (struct-case x [(constant) x] [(primcall op rands) (let ([a0 (car rands)] [a1 (cadr rands)]) @@ -2286,7 +2286,7 @@ (make-shortcut body (P handler)))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) - (record-case x + (struct-case x [(primcall op rands) x] [(conditional e0 e1 e2) (make-conditional (P e0) (T e1) (T e2))] @@ -2299,7 +2299,7 @@ ;;; (define (color-program x) (define who 'color-program) - (record-case x + (struct-case x [(locals vars body) (let ([varvec (car vars)] [sp* (cdr vars)]) (let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body]) @@ -2316,17 +2316,17 @@ (define (color-by-chaitin x) ;;; (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (color-program body))])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) free* name)])) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (make-codes (map Clambda code*) (color-program body))])) ;;; @@ -2344,7 +2344,7 @@ `(disp ,(* i (- wordsize)) ,fpr)) ;;; (define (C x) - (record-case x + (struct-case x [(code-loc label) (label-address label)] [(foreign-label L) `(foreign-label ,L)] [(closure label free*) @@ -2357,19 +2357,19 @@ x (error who "invalid constant C ~s" x))])) (define (BYTE x) - (record-case x + (struct-case x [(constant x) (unless (and (integer? x) (fx<= x 255) (fx<= -128 x)) (error who "invalid byte ~s" x)) x] [else (error who "invalid byte ~s" x)])) (define (D x) - (record-case x + (struct-case x [(constant c) (C c)] [else (if (symbol? x) x (error who "invalid D ~s" x))])) (define (R x) - (record-case x + (struct-case x [(constant c) (C c)] [(fvar i) (FVar i)] [(disp s0 s1) @@ -2378,7 +2378,7 @@ [else (if (symbol? x) x (error who "invalid R ~s" x))])) (define (R/l x) - (record-case x + (struct-case x [(constant c) (C c)] [(fvar i) (FVar i)] [(disp s0 s1) @@ -2397,7 +2397,7 @@ => cadr] [else (error who "invalid reg/l ~s" x)])) (define (R/cl x) - (record-case x + (struct-case x [(constant i) (unless (fixnum? i) (error who "invalid R/cl ~s" x)) @@ -2407,12 +2407,12 @@ '%cl (error who "invalid R/cl ~s" x))])) (define (interrupt? x) - (record-case x + (struct-case x [(primcall op args) (eq? op 'interrupt)] [else #f])) ;;; flatten effect (define (E x ac) - (record-case x + (struct-case x [(seq e0 e1) (E e0 (E e1 ac))] [(conditional e0 e1 e2) (cond @@ -2568,7 +2568,7 @@ (label (gensym))) ;;; (define (P x lt lf ac) - (record-case x + (struct-case x [(constant c) (if c (if lt (cons `(jmp ,lt) ac) ac) @@ -2668,7 +2668,7 @@ [else (error who "invalid pred ~s" x)])) ;;; (define (T x ac) - (record-case x + (struct-case x [(seq e0 e1) (E e0 (T e1 ac))] [(conditional e0 e1 e2) (let ([L (unique-label)]) @@ -2756,9 +2756,9 @@ (handle-vararg (length (cdr args)) ac)])) ;;; (define (ClambdaCase x ac) - (record-case x + (struct-case x [(clambda-case info body) - (record-case info + (struct-case info [(case-info L args proper) (let ([lothers (unique-label)]) (cons* `(cmpl ,(argc-convention @@ -2777,7 +2777,7 @@ (T body (cons lothers ac))))))])])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda L case* free* name) (cons* (length free*) `(name ,name) @@ -2794,7 +2794,7 @@ (define exceptions-conc (make-parameter #f)) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (cons (cons* 0 (label (gensym)) diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index c61e734..2e5f7ca 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -8,7 +8,7 @@ (ikarus system $fx) (ikarus system $pairs) (only (ikarus system $codes) $code->closure) - (only (ikarus system $records) $record-ref $record/rtd?) + (only (ikarus system $structs) $struct-ref $struct/rtd?) (except (ikarus) compile-core-expr-to-port assembler-output current-primitive-locations eval-core) @@ -17,7 +17,7 @@ ) -(define-syntax record-case +(define-syntax struct-case (lambda (x) (define (enumerate fld* i) (syntax-case fld* () @@ -33,8 +33,8 @@ (with-syntax ([altern (generate-body ctxt #'rest)] [(id* ...) (enumerate #'(rec-field* ...) 0)] [rtd #'(type-descriptor rec-name)]) - #'(if ($record/rtd? v rtd) - (let ([rec-field* ($record-ref v id*)] ...) + #'(if ($struct/rtd? v rtd) + (let ([rec-field* ($struct-ref v id*)] ...) b b* ...) altern))])) (syntax-case x () @@ -45,55 +45,55 @@ (include "set-operations.ss") -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var +(define-struct constant (value)) +(define-struct code-loc (label)) +(define-struct foreign-label (label)) +(define-struct var (name assigned referenced reg-conf frm-conf var-conf reg-move frm-move var-move loc index)) -(define-record cp-var (idx)) -(define-record frame-var (idx)) -(define-record new-frame (base-idx size body)) -(define-record save-cp (loc)) -(define-record eval-cp (check body)) -(define-record return (value)) -(define-record call-cp +(define-struct cp-var (idx)) +(define-struct frame-var (idx)) +(define-struct new-frame (base-idx size body)) +(define-struct save-cp (loc)) +(define-struct eval-cp (check body)) +(define-struct return (value)) +(define-struct call-cp (call-convention label save-cp? rp-convention base-idx arg-count live-mask)) -(define-record tailcall-cp (convention label arg-count)) -(define-record primcall (op arg*)) -(define-record primref (name)) -(define-record conditional (test conseq altern)) -(define-record interrupt-call (test handler)) -(define-record bind (lhs* rhs* body)) -(define-record recbind (lhs* rhs* body)) -(define-record rec*bind (lhs* rhs* body)) -(define-record fix (lhs* rhs* body)) +(define-struct tailcall-cp (convention label arg-count)) +(define-struct primcall (op arg*)) +(define-struct primref (name)) +(define-struct conditional (test conseq altern)) +(define-struct interrupt-call (test handler)) +(define-struct bind (lhs* rhs* body)) +(define-struct recbind (lhs* rhs* body)) +(define-struct rec*bind (lhs* rhs* body)) +(define-struct fix (lhs* rhs* body)) -(define-record seq (e0 e1)) -(define-record case-info (label args proper)) -(define-record clambda-case (info body)) -(define-record clambda (label cases free name)) -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record jmpcall (label op rand*)) -(define-record forcall (op rand*)) -(define-record codes (list body)) -(define-record assign (lhs rhs)) -(define-record mvcall (producer consumer)) +(define-struct seq (e0 e1)) +(define-struct case-info (label args proper)) +(define-struct clambda-case (info body)) +(define-struct clambda (label cases free name)) +(define-struct closure (code free*)) +(define-struct funcall (op rand*)) +(define-struct jmpcall (label op rand*)) +(define-struct forcall (op rand*)) +(define-struct codes (list body)) +(define-struct assign (lhs rhs)) +(define-struct mvcall (producer consumer)) -(define-record shortcut (body handler)) +(define-struct shortcut (body handler)) -(define-record fvar (idx)) -(define-record object (val)) -(define-record locals (vars body)) -(define-record nframe (vars live body)) -(define-record nfv (conf loc var-conf frm-conf nfv-conf)) -(define-record ntcall (target value args mask size)) -(define-record asm-instr (op dst src)) -(define-record disp (s0 s1)) +(define-struct fvar (idx)) +(define-struct object (val)) +(define-struct locals (vars body)) +(define-struct nframe (vars live body)) +(define-struct nfv (conf loc var-conf frm-conf nfv-conf)) +(define-struct ntcall (target value args mask size)) +(define-struct asm-instr (op dst src)) +(define-struct disp (s0 s1)) (define mkfvar (let ([cache '()]) @@ -266,7 +266,7 @@ [(null? d) (E a)] [else (cons (E a) (f (car d) (cdr d)))])))) (define (E x) - (record-case x + (struct-case x [(constant c) `(quote ,c)] [(code-loc x) `(code-loc ,x)] [(var x) (string->symbol (format "v:~a" x))] @@ -291,7 +291,7 @@ [(seq e0 e1) (let () (define (f x ac) - (record-case x + (struct-case x [(seq e0 e1) (f e0 (f e1 ac))] [else (cons (E x) ac)])) (cons 'begin (f e0 (f e1 '()))))] @@ -376,9 +376,9 @@ (list (make-conses rhs*))] [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) (define (inline-case cls rand*) - (record-case cls + (struct-case cls [(clambda-case info body) - (record-case info + (struct-case info [(case-info label fml* proper) (if proper (and (fx= (length fml*) (length rand*)) @@ -392,26 +392,26 @@ [else (try-inline (cdr cls*) rand* default)])) (define (inline rator rand*) (define (valid-mv-consumer? x) - (record-case x + (struct-case x [(clambda L cases F) (and (fx= (length cases) 1) - (record-case (car cases) + (struct-case (car cases) [(clambda-case info body) - (record-case info + (struct-case info [(case-info L args proper) proper])]))] [else #f])) (define (single-value-consumer? x) - (record-case x + (struct-case x [(clambda L cases F) (and (fx= (length cases) 1) - (record-case (car cases) + (struct-case (car cases) [(clambda-case info body) - (record-case info + (struct-case info [(case-info L args proper) (and proper (fx= (length args) 1))])]))] [else #f])) (define (valid-mv-producer? x) - (record-case x + (struct-case x [(funcall) #t] [(conditional) #f] [(bind lhs* rhs* body) (valid-mv-producer? body)] @@ -419,7 +419,7 @@ ; [else (error 'valid-mv-producer? "unhandles ~s" ; (unparse x))] )) - (record-case rator + (struct-case rator [(clambda g cls*) (try-inline cls* rand* (make-funcall rator rand*))] @@ -445,7 +445,7 @@ (make-funcall rator rand*)])] [else (make-funcall rator rand*)])) (define (Expr x) - (record-case x + (struct-case x [(constant) x] [(var) x] [(primref) x] @@ -465,7 +465,7 @@ [(clambda g cls* free name) (make-clambda g (map (lambda (x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Expr body))])) cls*) @@ -586,7 +586,7 @@ (make-assign (car lhs*) (car rhs*)) (build-assign* (cdr lhs*) (cdr rhs*) body))])) (define (E x ref comp) - (record-case x + (struct-case x [(constant) x] [(var) (ref x) x] [(assign lhs rhs) @@ -613,7 +613,7 @@ [(clambda g cls* free name) (make-clambda g (map (lambda (x) - (record-case x + (struct-case x [(clambda-case info body) (let ([h (make-eq-hashtable)]) (let ([body (E body (extend-hash (case-info-args info) h ref) void)]) @@ -622,7 +622,7 @@ free name)] [(funcall rator rand*) (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)]) - (record-case rator + (struct-case rator [(primref op) (unless (memq op simple-primitives) (comp))] @@ -648,7 +648,7 @@ (set-var-assigned! x #f) (set-var-referenced! x #f)) (define (Expr x) - (record-case x + (struct-case x [(constant) (void)] [(var) (set-var-referenced! x #t)] [(primref) (void)] @@ -667,7 +667,7 @@ [(clambda g cls*) (for-each (lambda (cls) - (record-case cls + (struct-case cls [(clambda-case info body) (for-each init-var (case-info-args info)) (Expr body)])) @@ -727,7 +727,7 @@ [else (make-funcall (make-primref op) rand*)])) (define (constant-value x k) - (record-case x + (struct-case x [(constant t) (k t)] ; known [(bind lhs* rhs* body) (constant-value body k)] [(fix lhs* rhs* body) (constant-value body k)] @@ -887,7 +887,7 @@ [(p) (mk-seq (mk-seq a0 a1) (make-constant #t))] [else (giveup)]))) (giveup))] - [($record-ref $record/rtd?) + [($record-ref $record/rtd? $struct-ref $struct/rtd?) (or (and (fx= (length rand*) 2) (let ([a0 (car rand*)] [a1 (cadr rand*)]) (case ctxt @@ -1044,7 +1044,7 @@ (define (mk-mvcall p c) - (record-case p + (struct-case p [(funcall) (make-mvcall p c)] [(seq e0 e1) (make-seq e0 (mk-mvcall e1 c))] @@ -1057,7 +1057,7 @@ (define who 'copy-propagate) (define the-void (make-constant (void))) (define (known-value x) - (record-case x + (struct-case x [(constant) x] ; known [(primref) x] ; known [(bind lhs* rhs* body) (known-value body)] @@ -1076,7 +1076,7 @@ (primref-name y)))] [else #f])) (define (predicate-value x) - (record-case x + (struct-case x [(constant t) (if t 't 'f)] [(bind lhs rhs body) (predicate-value body)] [(fix lhs rhs body) (predicate-value body)] @@ -1148,13 +1148,13 @@ (define (do-clambda g cls* free name) (make-clambda g (map (lambda (cls) - (record-case cls + (struct-case cls [(clambda-case info body) (make-clambda-case info (Value body))])) cls*) free name)) (define (Effect x) - (record-case x + (struct-case x [(constant) the-void] [(var) the-void] [(primref) the-void] @@ -1179,7 +1179,7 @@ (cond [(known-value rator) => (lambda (v) - (record-case v + (struct-case v [(primref op) (mk-seq rator (optimize-primcall 'e op (map Value rand*)))] @@ -1198,7 +1198,7 @@ (Effect rhs))] [else (error who "invalid effect expression ~s" (unparse x))])) (define (Pred x) - (record-case x + (struct-case x [(constant) x] [(var) (let ([r (var-referenced x)]) @@ -1237,7 +1237,7 @@ (cond [(known-value rator) => (lambda (v) - (record-case v + (struct-case v [(primref op) (mk-seq rator (optimize-primcall 'p op (map Value rand*)))] @@ -1252,7 +1252,7 @@ (mk-mvcall (Value p) (Value c))] [else (error who "invalid pred expression ~s" (unparse x))])) (define (Value x) - (record-case x + (struct-case x [(constant) x] [(var) (let ([r (var-referenced x)]) @@ -1289,7 +1289,7 @@ (cond [(known-value rator) => (lambda (v) - (record-case v + (struct-case v [(primref op) (mk-seq rator (optimize-primcall 'v op (map Value rand*)))] @@ -1331,7 +1331,7 @@ (map (lambda (rhs) (make-funcall (make-primref 'vector) (list rhs))) rhs*) body)])) (define (Expr x) - (record-case x + (struct-case x [(constant) x] [(var) (cond @@ -1351,9 +1351,9 @@ [(clambda g cls* free name) (make-clambda g (map (lambda (cls) - (record-case cls + (struct-case cls [(clambda-case info body) - (record-case info + (struct-case info [(case-info label fml* proper) (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)]) (make-clambda-case @@ -1383,7 +1383,7 @@ (define (init-var x) (set-var-referenced! x #f)) (define (set-var x v) - (record-case v + (struct-case v [(clambda) (set-var-referenced! x v)] [(var) (cond @@ -1394,7 +1394,7 @@ (var-referenced x)) (define (optimize c rator rand*) (let ([n (length rand*)]) - (record-case c + (struct-case c [(clambda main-label cls*) (let f ([cls* cls*]) (cond @@ -1402,7 +1402,7 @@ ;;; none matching? (make-funcall rator rand*)] [else - (record-case (clambda-case-info (car cls*)) + (struct-case (clambda-case-info (car cls*)) [(case-info label fml* proper) (cond [proper @@ -1421,7 +1421,7 @@ (f (cdr fml*) (cdr rand*)))]))) (f (cdr cls*)))])])]))]))) (define (Expr x) - (record-case x + (struct-case x [(constant) x] [(var) x] [(primref) x] @@ -1439,7 +1439,7 @@ [(clambda g cls* free name) (make-clambda g (map (lambda (cls) - (record-case cls + (struct-case cls [(clambda-case info body) (for-each init-var (case-info-args info)) (make-clambda-case info (Expr body))])) @@ -1484,14 +1484,14 @@ [(d d-free) (do-clambda* (cdr x*))]) (values (cons a d) (union a-free d-free)))])) (define (do-clambda x) - (record-case x + (struct-case x [(clambda g cls* _free name) (let-values ([(cls* free) (let f ([cls* cls*]) (cond [(null? cls*) (values '() '())] [else - (record-case (car cls*) + (struct-case (car cls*) [(clambda-case info body) (let-values ([(body body-free) (Expr body)] [(cls* cls*-free) (f (cdr cls*))]) @@ -1502,7 +1502,7 @@ (values (make-closure (make-clambda g cls* free name) free) free))])) (define (Expr ex) - (record-case ex + (struct-case ex [(constant) (values ex '())] [(var) (values ex (singleton ex))] [(primref) (values ex '())] @@ -1544,7 +1544,7 @@ [(mvcall p c) (let-values ([(p p-free) (Expr p)] [(c c-free) (Expr c)]) - (record-case c + (struct-case c [(closure code free^) (values (make-mvcall p code) (union p-free c-free))] @@ -1574,16 +1574,16 @@ (define (make-thunk-var var thunk) (set-var-referenced! var thunk)) (define (thunk? x) - (record-case x + (struct-case x [(closure code free*) (null? free*)] [else #f])) (define (trim/lift-code code free*) - (record-case code + (struct-case code [(clambda label cls* free*/dropped name) (let ([cls* (map (lambda (x) - (record-case x + (struct-case x [(clambda-case info body) (for-each init-non-thunk (case-info-args info)) @@ -1617,7 +1617,7 @@ (for-each init-non-thunk lhs*) (let ([free** ;;; trim the free lists first; after init. (map (lambda (x) (trim-vars (closure-free* x))) rhs*)]) - (define-record node (name code deps whacked free)) + (define-struct node (name code deps whacked free)) (let ([node* (map (lambda (lhs rhs) (let ([n (make-node lhs (closure-code rhs) '() #f '())]) (make-thunk-var lhs n) @@ -1679,7 +1679,7 @@ (trim-thunks rhs*) (E body)))))) (define (E x) - (record-case x + (struct-case x [(constant) x] [(var) (or (var-thunk x) x)] [(primref) x] @@ -1693,12 +1693,12 @@ [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] [(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))] [(mvcall p c) - (record-case c + (struct-case c [(clambda label cases free name) (make-mvcall (E p) (make-clambda label (map (lambda (x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (E body))])) cases) @@ -1718,15 +1718,15 @@ (make-funcall (make-primref '$do-event) '())) x)) (define (CaseExpr x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (Tail body))])) (define (CodeExpr x) - (record-case x + (struct-case x [(clambda L cases free name) (make-clambda L (map CaseExpr cases) free name)])) (define (CodesExpr x) - (record-case x + (struct-case x [(codes list body) (make-codes (map CodeExpr list) (Tail body))])) (CodesExpr x)) @@ -1886,8 +1886,8 @@ (define tcbucket-size 16) (define record-ptag 5) (define record-pmask 7) - (define disp-record-rtd 0) - (define disp-record-data 4) + (define disp-struct-rtd 0) + (define disp-struct-data 4) (define disp-frame-size -17) (define disp-frame-offset -13) (define disp-multivalue-rp -9) diff --git a/src/ikarus.fasl.ss b/src/ikarus.fasl.ss index 3bf03dd..3492b9f 100644 --- a/src/ikarus.fasl.ss +++ b/src/ikarus.fasl.ss @@ -43,7 +43,7 @@ (import (ikarus) (except (ikarus code-objects) procedure-annotation) (ikarus system $codes) - (ikarus system $records)) + (ikarus system $structs)) (define who 'fasl-read) (define (assert-eq? x y) @@ -218,18 +218,18 @@ [else (let ([a (read)]) (cons a (f (fxadd1 i))))]))]) - (let ([rtd (make-record-type + (let ([rtd (make-struct-type rtd-name fields rtd-symbol)]) (when m (put-mark m rtd)) rtd)))] [(#\{) (let ([n (read-int p)]) (let ([rtd (read)]) - (let ([x ($make-record rtd n)]) + (let ([x ($make-struct rtd n)]) (when m (put-mark m x)) (let f ([i 0]) (unless (fx= i n) - (record-set! x i (read)) + ($struct-set! x i (read)) (f (fxadd1 i)))) x)))] [(#\C) diff --git a/src/ikarus.fasl.write.ss b/src/ikarus.fasl.write.ss index 83794dc..b62aa76 100644 --- a/src/ikarus.fasl.write.ss +++ b/src/ikarus.fasl.write.ss @@ -5,7 +5,7 @@ (rnrs hashtables) (ikarus system $codes) (ikarus system $pairs) - (ikarus system $records) + (ikarus system $structs) (ikarus system $io) (ikarus system $bytevectors) (ikarus system $fx) @@ -139,16 +139,16 @@ (write-byte (code-ref x i) p) (f (fxadd1 i) n))) (fasl-write-object (code-reloc-vector x) p h m))] - [(record? x) - (let ([rtd (record-type-descriptor x)]) + [(struct? x) + (let ([rtd (struct-type-descriptor x)]) (cond [(eq? rtd (base-rtd)) ;;; rtd record (write-char #\R p) - (let ([names (record-type-field-names x)] + (let ([names (struct-type-field-names x)] [m - (fasl-write-object (record-type-symbol x) p h - (fasl-write-object (record-type-name x) p h m))]) + (fasl-write-object (struct-type-symbol x) p h + (fasl-write-object (struct-type-name x) p h m))]) (write-int (length names) p) (let f ([names names] [m m]) (cond @@ -159,15 +159,15 @@ [else ;;; non-rtd record (write-char #\{ p) - (write-int (length (record-type-field-names rtd)) p) - (let f ([names (record-type-field-names rtd)] + (write-int (length (struct-type-field-names rtd)) p) + (let f ([names (struct-type-field-names rtd)] [m (fasl-write-object rtd p h m)]) (cond [(null? names) m] [else (f (cdr names) (fasl-write-object - ((record-field-accessor rtd (car names)) x) + ((struct-field-accessor rtd (car names)) x) p h m))]))]))] [(procedure? x) (write-char #\Q p) @@ -253,24 +253,24 @@ [(code? x) (make-graph ($code-annotation x) h) (make-graph (code-reloc-vector x) h)] - [(record? x) + [(struct? x) (when (eq? x (base-rtd)) (error 'fasl-write "base-rtd is not writable")) - (let ([rtd (record-type-descriptor x)]) + (let ([rtd (struct-type-descriptor x)]) (cond [(eq? rtd (base-rtd)) ;;; this is an rtd - (make-graph (record-type-name x) h) - (make-graph (record-type-symbol x) h) + (make-graph (struct-type-name x) h) + (make-graph (struct-type-symbol x) h) (for-each (lambda (x) (make-graph x h)) - (record-type-field-names x))] + (struct-type-field-names x))] [else ;;; this is a record (make-graph rtd h) (for-each (lambda (name) - (make-graph ((record-field-accessor rtd name) x) h)) - (record-type-field-names rtd))]))] + (make-graph ((struct-field-accessor rtd name) x) h)) + (struct-type-field-names rtd))]))] [(procedure? x) (let ([code ($closure-code x)]) (unless (fxzero? (code-freevars code)) diff --git a/src/ikarus.hash-tables.ss b/src/ikarus.hash-tables.ss index 5c4fa67..f9fcba9 100644 --- a/src/ikarus.hash-tables.ss +++ b/src/ikarus.hash-tables.ss @@ -14,7 +14,7 @@ hashtable-update! hashtable-keys hashtable-mutable? hashtable-clear!)) - (define-record hasht (vec count tc mutable?)) + (define-struct hasht (vec count tc mutable?)) ;;; directly from Dybvig's paper (define tc-pop diff --git a/src/ikarus.pretty-print.ss b/src/ikarus.pretty-print.ss index e5e7515..5d7b65c 100644 --- a/src/ikarus.pretty-print.ss +++ b/src/ikarus.pretty-print.ss @@ -13,11 +13,11 @@ (cons a (map1ltr f (cdr ls))))])) (define (pretty-width) 80) (define (pretty-indent) 1) - (define-record cbox (length boxes)) - (define-record pbox (length ls last)) - (define-record mbox (length str val)) - (define-record vbox (length ls)) - (define-record fbox (length box* sep*)) + (define-struct cbox (length boxes)) + (define-struct pbox (length ls last)) + (define-struct mbox (length str val)) + (define-struct vbox (length ls)) + (define-struct fbox (length box* sep*)) (define (box-length x) (cond [(string? x) (string-length x)] @@ -511,8 +511,8 @@ (dynamic x)) rv) - (define-record setbox (idx data)) - (define-record refbox (idx)) + (define-struct setbox (idx data)) + (define-struct refbox (idx)) (define (rewrite-shared x h) (define counter 0) @@ -608,7 +608,7 @@ (set-fmt! 'define '(_ name tab e tab e ...)) (set-fmt! 'case-lambda '(_ tab [0 e ...] ...)) - (set-fmt! 'record-case + (set-fmt! 'struct-case '(_ e tab [e 0 e ...] ...)) (set-fmt! 'if '(_ test 3 e ...)) (set-fmt! 'and '(and test 4 e ...)) diff --git a/src/ikarus.reader.ss b/src/ikarus.reader.ss index f731ca6..e3bde26 100644 --- a/src/ikarus.reader.ss +++ b/src/ikarus.reader.ss @@ -962,7 +962,7 @@ [else (let-values ([(a locs k) (parse-token p locs k t)]) (read-bytevector p locs k (fxadd1 count) (cons a ls)))])))) - (define-record loc (value set?)) + (define-struct loc (value set?)) (define parse-token (lambda (p locs k t) (cond diff --git a/src/ikarus.records.ss b/src/ikarus.records.ss deleted file mode 100644 index c456e62..0000000 --- a/src/ikarus.records.ss +++ /dev/null @@ -1,273 +0,0 @@ - - -(library (ikarus records) - (export - make-record-type record-type-name record-type-symbol - record-type-field-names record-constructor record-predicate - record-field-accessor record-field-mutator record? record-rtd - set-rtd-printer! - (rename (record-rtd record-type-descriptor)) - record-name record-printer record-length record-ref record-set!) - - (import - (ikarus system $records) - (ikarus system $pairs) - (ikarus system $fx) - (except (ikarus) - make-record-type record-type-name record-type-symbol - record-type-field-names record-constructor record-predicate - record-field-accessor record-field-mutator record? record-rtd - record-type-descriptor record-name record-printer record-length - record-ref record-set! set-rtd-printer!)) - - - - (define rtd? - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) (base-rtd))))) - - (define rtd-name - (lambda (rtd) - ($record-ref rtd 0))) - - (define rtd-length - (lambda (rtd) - ($record-ref rtd 1))) - - (define rtd-fields - (lambda (rtd) - ($record-ref rtd 2))) - - (define rtd-printer - (lambda (rtd) - ($record-ref rtd 3))) - - (define rtd-symbol - (lambda (rtd) - ($record-ref rtd 4))) - - (define set-rtd-name! - (lambda (rtd name) - ($record-set! rtd 0 name))) - - (define set-rtd-length! - (lambda (rtd n) - ($record-set! rtd 1 n))) - - (define set-rtd-fields! - (lambda (rtd fields) - ($record-set! rtd 2 fields))) - - (define $set-rtd-printer! - (lambda (rtd printer) - ($record-set! rtd 3 printer))) - - (define set-rtd-symbol! - (lambda (rtd symbol) - ($record-set! rtd 4 symbol))) - - (define make-rtd - (lambda (name fields printer symbol) - ($record (base-rtd) name (length fields) fields printer symbol))) - - (define verify-field - (lambda (x) - (unless (symbol? x) - (error 'make-record-type "~s is not a valid field name" x)))) - - (define set-fields - (lambda (r f* i n) - (cond - [(null? f*) - (if ($fx= i n) - r - #f)] - [($fx< i n) - (if (null? f*) - #f - (begin - ($record-set! r i ($car f*)) - (set-fields r ($cdr f*) ($fxadd1 i) n)))] - [else #f]))) - - (define make-record-type - (case-lambda - [(name fields) - (unless (string? name) - (error 'make-record-type "name must be a string, got ~s" name)) - (unless (list? fields) - (error 'make-record-type "fields must be a list, got ~s" fields)) - (for-each verify-field fields) - (let ([g (gensym name)]) - (let ([rtd (make-rtd name fields #f g)]) - (set-symbol-value! g rtd) - rtd))] - [(name fields g) - (unless (string? name) - (error 'make-record-type "name must be a string, got ~s" name)) - (unless (list? fields) - (error 'make-record-type "fields must be a list, got ~s" fields)) - (for-each verify-field fields) - (cond - [(symbol-bound? g) - (let ([rtd (symbol-value g)]) - (unless (and (string=? name (record-type-name rtd)) - (equal? fields (record-type-field-names rtd))) - (error 'make-record-type "definition mismatch")) - rtd)] - [else - (let ([rtd (make-rtd name fields #f g)]) - (set-symbol-value! g rtd) - rtd)])])) - - (define record-type-name - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-type-name "~s is not an rtd" rtd)) - (rtd-name rtd))) - - (define record-type-symbol - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-type-symbol "~s is not an rtd" rtd)) - (rtd-symbol rtd))) - - (define record-type-field-names - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-type-field-names "~s is not an rtd" rtd)) - (rtd-fields rtd))) - - - (define record-constructor - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-constructor "~s is not an rtd")) - (lambda args - (let ([n (rtd-length rtd)]) - (let ([r ($make-record rtd n)]) - (or (set-fields r args 0 n) - (error 'record-constructor - "incorrect number of arguments to the constructor of ~s" - rtd))))))) - - (define record-predicate - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-predicate "~s is not an rtd")) - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) rtd))))) - - (define field-index - (lambda (i rtd who) - (cond - [(fixnum? i) - (unless (and ($fx>= i 0) ($fx< i (rtd-length rtd))) - (error who "~s is out of range for rtd ~s" rtd)) - i] - [(symbol? i) - (letrec ([lookup - (lambda (n ls) - (cond - [(null? ls) - (error who "~s is not a field in ~s" rtd)] - [(eq? i ($car ls)) n] - [else (lookup ($fx+ n 1) ($cdr ls))]))]) - (lookup 0 (rtd-fields rtd)))] - [else (error who "~s is not a valid index" i)]))) - - (define record-field-accessor - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-accessor "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-accessor)]) - (lambda (x) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-accessor "~s is not of type ~s" x rtd)) - ($record-ref x i))))) - - (define record-field-mutator - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-mutator "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-mutator)]) - (lambda (x v) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-mutator "~s is not of type ~s" x rtd)) - ($record-set! x i v))))) - - (define record? - (lambda (x . rest) - (if (null? rest) - ($record? x) - (let ([rtd ($car rest)]) - (unless (null? ($cdr rest)) - (error 'record? "too many arguments")) - (unless (rtd? rtd) - (error 'record? "~s is not an rtd")) - (and ($record? x) - (eq? ($record-rtd x) rtd)))))) - - (define record-rtd - (lambda (x) - (if ($record? x) - ($record-rtd x) - (error 'record-rtd "~s is not a record" x)))) - - (define record-length - (lambda (x) - (if ($record? x) - (rtd-length ($record-rtd x)) - (error 'record-length "~s is not a record" x)))) - - (define record-name - (lambda (x) - (if ($record? x) - (rtd-name ($record-rtd x)) - (error 'record-name "~s is not a record" x)))) - - (define record-printer - (lambda (x) - (if ($record? x) - (rtd-printer ($record-rtd x)) - (error 'record-printer "~s is not a record" x)))) - - (define record-ref - (lambda (x i) - (unless ($record? x) (error 'record-ref "~s is not a record" x)) - (unless (fixnum? i) (error 'record-ref "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-ref "index ~s is out of range for ~s" i x)) - ($record-ref x i)))) - - (define record-set! - (lambda (x i v) - (unless ($record? x) (error 'record-set! "~s is not a record" x)) - (unless (fixnum? i) (error 'record-set! "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-set! "index ~s is out of range for ~s" i x)) - ($record-set! x i v)))) - - (define (set-rtd-printer! x p) - (unless (rtd? x) - (error 'set-rtd-printer! "~s is not an rtd" x)) - (unless (procedure? p) - (error 'set-rtd-printer! "~s is not a procedure" p)) - ($set-rtd-printer! x p)) - - (set-rtd-fields! (base-rtd) '(name fields length printer symbol)) - (set-rtd-name! (base-rtd) "base-rtd") - ($set-rtd-printer! (base-rtd) - (lambda (x p) - (unless (rtd? x) - (error 'record-type-printer "not an rtd")) - (display "#<" p) - (display (rtd-name x) p) - (display " rtd>" p))) - ) diff --git a/src/ikarus.singular-objects.ss b/src/ikarus.singular-objects.ss index 15ae05f..ddf10a4 100644 --- a/src/ikarus.singular-objects.ss +++ b/src/ikarus.singular-objects.ss @@ -3,7 +3,7 @@ (export base-rtd eof-object void fixnum-width least-fixnum greatest-fixnum) (import - (rename (ikarus system $records) (base-rtd sys:base-rtd)) + (rename (ikarus system $structs) (base-rtd sys:base-rtd)) (rename (ikarus) (void sys:void) (fixnum-width sys:fixnum-width) diff --git a/src/ikarus.structs.ss b/src/ikarus.structs.ss new file mode 100644 index 0000000..74e475d --- /dev/null +++ b/src/ikarus.structs.ss @@ -0,0 +1,273 @@ + + +(library (ikarus structs) + (export + make-struct-type struct-type-name struct-type-symbol + struct-type-field-names struct-constructor struct-predicate + struct-field-accessor struct-field-mutator struct? struct-rtd + set-rtd-printer! + (rename (struct-rtd struct-type-descriptor)) + struct-name struct-printer struct-length struct-ref struct-set!) + + (import + (ikarus system $structs) + (ikarus system $pairs) + (ikarus system $fx) + (except (ikarus) + make-struct-type struct-type-name struct-type-symbol + struct-type-field-names struct-constructor struct-predicate + struct-field-accessor struct-field-mutator struct? struct-rtd + struct-type-descriptor struct-name struct-printer struct-length + struct-ref struct-set! set-rtd-printer!)) + + + + (define rtd? + (lambda (x) + (and ($struct? x) + (eq? ($struct-rtd x) (base-rtd))))) + + (define rtd-name + (lambda (rtd) + ($struct-ref rtd 0))) + + (define rtd-length + (lambda (rtd) + ($struct-ref rtd 1))) + + (define rtd-fields + (lambda (rtd) + ($struct-ref rtd 2))) + + (define rtd-printer + (lambda (rtd) + ($struct-ref rtd 3))) + + (define rtd-symbol + (lambda (rtd) + ($struct-ref rtd 4))) + + (define set-rtd-name! + (lambda (rtd name) + ($struct-set! rtd 0 name))) + + (define set-rtd-length! + (lambda (rtd n) + ($struct-set! rtd 1 n))) + + (define set-rtd-fields! + (lambda (rtd fields) + ($struct-set! rtd 2 fields))) + + (define $set-rtd-printer! + (lambda (rtd printer) + ($struct-set! rtd 3 printer))) + + (define set-rtd-symbol! + (lambda (rtd symbol) + ($struct-set! rtd 4 symbol))) + + (define make-rtd + (lambda (name fields printer symbol) + ($struct (base-rtd) name (length fields) fields printer symbol))) + + (define verify-field + (lambda (x) + (unless (symbol? x) + (error 'make-struct-type "~s is not a valid field name" x)))) + + (define set-fields + (lambda (r f* i n) + (cond + [(null? f*) + (if ($fx= i n) + r + #f)] + [($fx< i n) + (if (null? f*) + #f + (begin + ($struct-set! r i ($car f*)) + (set-fields r ($cdr f*) ($fxadd1 i) n)))] + [else #f]))) + + (define make-struct-type + (case-lambda + [(name fields) + (unless (string? name) + (error 'make-struct-type "name must be a string, got ~s" name)) + (unless (list? fields) + (error 'make-struct-type "fields must be a list, got ~s" fields)) + (for-each verify-field fields) + (let ([g (gensym name)]) + (let ([rtd (make-rtd name fields #f g)]) + (set-symbol-value! g rtd) + rtd))] + [(name fields g) + (unless (string? name) + (error 'make-struct-type "name must be a string, got ~s" name)) + (unless (list? fields) + (error 'make-struct-type "fields must be a list, got ~s" fields)) + (for-each verify-field fields) + (cond + [(symbol-bound? g) + (let ([rtd (symbol-value g)]) + (unless (and (string=? name (struct-type-name rtd)) + (equal? fields (struct-type-field-names rtd))) + (error 'make-struct-type "definition mismatch")) + rtd)] + [else + (let ([rtd (make-rtd name fields #f g)]) + (set-symbol-value! g rtd) + rtd)])])) + + (define struct-type-name + (lambda (rtd) + (unless (rtd? rtd) + (error 'struct-type-name "~s is not an rtd" rtd)) + (rtd-name rtd))) + + (define struct-type-symbol + (lambda (rtd) + (unless (rtd? rtd) + (error 'struct-type-symbol "~s is not an rtd" rtd)) + (rtd-symbol rtd))) + + (define struct-type-field-names + (lambda (rtd) + (unless (rtd? rtd) + (error 'struct-type-field-names "~s is not an rtd" rtd)) + (rtd-fields rtd))) + + + (define struct-constructor + (lambda (rtd) + (unless (rtd? rtd) + (error 'struct-constructor "~s is not an rtd")) + (lambda args + (let ([n (rtd-length rtd)]) + (let ([r ($make-struct rtd n)]) + (or (set-fields r args 0 n) + (error 'struct-constructor + "incorrect number of arguments to the constructor of ~s" + rtd))))))) + + (define struct-predicate + (lambda (rtd) + (unless (rtd? rtd) + (error 'struct-predicate "~s is not an rtd")) + (lambda (x) + (and ($struct? x) + (eq? ($struct-rtd x) rtd))))) + + (define field-index + (lambda (i rtd who) + (cond + [(fixnum? i) + (unless (and ($fx>= i 0) ($fx< i (rtd-length rtd))) + (error who "~s is out of range for rtd ~s" rtd)) + i] + [(symbol? i) + (letrec ([lookup + (lambda (n ls) + (cond + [(null? ls) + (error who "~s is not a field in ~s" rtd)] + [(eq? i ($car ls)) n] + [else (lookup ($fx+ n 1) ($cdr ls))]))]) + (lookup 0 (rtd-fields rtd)))] + [else (error who "~s is not a valid index" i)]))) + + (define struct-field-accessor + (lambda (rtd i) + (unless (rtd? rtd) + (error 'struct-field-accessor "~s is not an rtd" rtd)) + (let ([i (field-index i rtd 'struct-field-accessor)]) + (lambda (x) + (unless (and ($struct? x) + (eq? ($struct-rtd x) rtd)) + (error 'struct-field-accessor "~s is not of type ~s" x rtd)) + ($struct-ref x i))))) + + (define struct-field-mutator + (lambda (rtd i) + (unless (rtd? rtd) + (error 'struct-field-mutator "~s is not an rtd" rtd)) + (let ([i (field-index i rtd 'struct-field-mutator)]) + (lambda (x v) + (unless (and ($struct? x) + (eq? ($struct-rtd x) rtd)) + (error 'struct-field-mutator "~s is not of type ~s" x rtd)) + ($struct-set! x i v))))) + + (define struct? + (lambda (x . rest) + (if (null? rest) + ($struct? x) + (let ([rtd ($car rest)]) + (unless (null? ($cdr rest)) + (error 'struct? "too many arguments")) + (unless (rtd? rtd) + (error 'struct? "~s is not an rtd")) + (and ($struct? x) + (eq? ($struct-rtd x) rtd)))))) + + (define struct-rtd + (lambda (x) + (if ($struct? x) + ($struct-rtd x) + (error 'struct-rtd "~s is not a struct" x)))) + + (define struct-length + (lambda (x) + (if ($struct? x) + (rtd-length ($struct-rtd x)) + (error 'struct-length "~s is not a struct" x)))) + + (define struct-name + (lambda (x) + (if ($struct? x) + (rtd-name ($struct-rtd x)) + (error 'struct-name "~s is not a struct" x)))) + + (define struct-printer + (lambda (x) + (if ($struct? x) + (rtd-printer ($struct-rtd x)) + (error 'struct-printer "~s is not a struct" x)))) + + (define struct-ref + (lambda (x i) + (unless ($struct? x) (error 'struct-ref "~s is not a struct" x)) + (unless (fixnum? i) (error 'struct-ref "~s is not a valid index" i)) + (let ([n (rtd-length ($struct-rtd x))]) + (unless (and ($fx>= i 0) ($fx< i n)) + (error 'struct-ref "index ~s is out of range for ~s" i x)) + ($struct-ref x i)))) + + (define struct-set! + (lambda (x i v) + (unless ($struct? x) (error 'struct-set! "~s is not a struct" x)) + (unless (fixnum? i) (error 'struct-set! "~s is not a valid index" i)) + (let ([n (rtd-length ($struct-rtd x))]) + (unless (and ($fx>= i 0) ($fx< i n)) + (error 'struct-set! "index ~s is out of range for ~s" i x)) + ($struct-set! x i v)))) + + (define (set-rtd-printer! x p) + (unless (rtd? x) + (error 'set-rtd-printer! "~s is not an rtd" x)) + (unless (procedure? p) + (error 'set-rtd-printer! "~s is not a procedure" p)) + ($set-rtd-printer! x p)) + + (set-rtd-fields! (base-rtd) '(name fields length printer symbol)) + (set-rtd-name! (base-rtd) "base-rtd") + ($set-rtd-printer! (base-rtd) + (lambda (x p) + (unless (rtd? x) + (error 'struct-type-printer "not an rtd")) + (display "#<" p) + (display (rtd-name x) p) + (display " rtd>" p))) + ) diff --git a/src/ikarus.timer.ss b/src/ikarus.timer.ss index 5fcf87f..523ab6c 100644 --- a/src/ikarus.timer.ss +++ b/src/ikarus.timer.ss @@ -3,7 +3,7 @@ (export time-it) (import (except (ikarus) time-it)) - (define-record stats + (define-struct stats (user-secs user-usecs sys-secs sys-usecs real-secs real-usecs diff --git a/src/ikarus.writer.ss b/src/ikarus.writer.ss index 35a8fe7..2dd4ca6 100644 --- a/src/ikarus.writer.ss +++ b/src/ikarus.writer.ss @@ -119,12 +119,12 @@ (write-char #\) p) i)) - (define write-record + (define write-struct (lambda (x p m h i) (write-char #\# p) (write-char #\[ p) - (let ([i (writer (record-name x) p m h i)]) - (let ([n (record-length x)]) + (let ([i (writer (struct-name x) p m h i)]) + (let ([n (struct-length x)]) (let f ([idx 0] [i i]) (cond [(fx= idx n) @@ -133,7 +133,7 @@ [else (write-char #\space p) (f (fxadd1 idx) - (writer (record-ref x idx) p m h i))])))))) + (writer (struct-ref x idx) p m h i))])))))) (define initial? (lambda (c) @@ -546,11 +546,11 @@ [(hashtable? x) (write-char* "#" p) i] - [(record? x) - (let ([printer (record-printer x)]) + [(struct? x) + (let ([printer (struct-printer x)]) (if (procedure? printer) (begin (printer x p) i) - (write-shareable x p m h i write-record)))] + (write-shareable x p m h i write-struct)))] [(code? x) (write-char* "#" p)] [($unbound-object? x) diff --git a/src/makefile.ss b/src/makefile.ss index 5102d6d..5f11ed2 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -37,7 +37,7 @@ "ikarus.lists.ss" "ikarus.fixnums.ss" "ikarus.chars.ss" - "ikarus.records.ss" + "ikarus.structs.ss" "ikarus.strings.ss" "ikarus.transcoders.ss" "ikarus.date-string.ss" @@ -104,7 +104,7 @@ [parameterize (core-macro . parameterize)] [case (core-macro . case)] [let-values (core-macro . let-values)] - [define-record (macro . define-record)] + [define-struct (macro . define-struct)] [include (macro . include)] [syntax-rules (macro . syntax-rules)] [quasiquote (macro . quasiquote)] @@ -193,7 +193,7 @@ [$fx (ikarus system $fx) #f #t] [$rat (ikarus system $ratnums) #f #t] [$symbols (ikarus system $symbols) #f #t] - [$records (ikarus system $records) #f #t] + [$structs (ikarus system $structs) #f #t] [$ports (ikarus system $ports) #f #t] [$codes (ikarus system $codes) #f #t] [$tcbuckets (ikarus system $tcbuckets) #f #t] @@ -211,7 +211,7 @@ [foreign-call i] [type-descriptor i] [parameterize i parameters] - [define-record i] + [define-struct i] [include i r] [time i] [trace-lambda i] @@ -310,16 +310,19 @@ [environment? i] [time-it i] [command-line-arguments i] - [make-record-type i] - [record-type-symbol i] [set-rtd-printer! i] - [record-name i] - [record-length i] - [record-printer i] - [record-ref i] - [record-set! i] - [record-field-accessor i] - [record-field-mutator i] + [make-record-type i] + [struct? i] + [make-struct-type i] + [struct-type-name i] + [struct-type-symbol i] + [struct-type-field-names i] + [struct-field-accessor i] + [struct-length i] + [struct-ref i] + [struct-printer i] + [struct-name i] + [struct-type-descriptor i] [code? i] [immediate? i] [pointer-value i] @@ -413,14 +416,16 @@ [$set-symbol-plist! $symbols] [$init-symbol-value! ] [$unbound-object? $symbols] - [base-rtd $records] - [$record-set! $records] - [$record-ref $records] - [$record-rtd $records] - [$record $records] - [$make-record $records] - [$record? $records] - [$record/rtd? $records] + + [base-rtd $structs] + [$struct-set! $structs] + [$struct-ref $structs] + [$struct-rtd $structs] + [$struct $structs] + [$make-struct $structs] + [$struct? $structs] + [$struct/rtd? $structs] + [$make-port/input $ports] [$make-port/output $ports] [$port-handler $ports] @@ -1129,25 +1134,25 @@ [parent-rtd i r rs] [protocol i r rs] [record-constructor-descriptor r rs] - [record-type-descriptor i r rs] + [record-type-descriptor r rs] [sealed i r rs] [nongenerative i r rs] [record-field-mutable? r ri] [record-rtd r ri] - [record-type-field-names i r ri] + [record-type-field-names r ri] [record-type-generative? r ri] - [record-type-name i r ri] + [record-type-name r ri] [record-type-opaque? r ri] [record-type-parent r ri] [record-type-sealed? r ri] [record-type-uid r ri] - [record? i r ri] + [record? r ri] [make-record-constructor-descriptor r rp] [make-record-type-descriptor r rp] [record-accessor r rp] - [record-constructor i r rp] + [record-constructor r rp] [record-mutator r rp] - [record-predicate i r rp] + [record-predicate r rp] [record-type-descriptor? r rp] [bound-identifier=? i r sc] [datum->syntax i r sc] @@ -1246,6 +1251,20 @@ [() set] [(x) (set! set (cons x set))]))) +(define (assq1 x ls) + (let f ([x x] [ls ls] [p #f]) + (cond + [(null? ls) p] + [(eq? x (caar ls)) + (if p + (if (pair? p) + (if (eq? (cdr p) (cdar ls)) + (f x (cdr ls) p) + (f x (cdr ls) 2)) + (f x (cdr ls) (+ p 1))) + (f x (cdr ls) (car ls)))] + [else (f x (cdr ls) p)]))) + (define (make-system-data subst env) (define who 'make-system-data) (let ([export-subst (make-collection)] @@ -1264,9 +1283,11 @@ (cond [(assq x (export-subst)) (error who "ambiguous export of ~s" x)] - [(assq x subst) => + [(assq1 x subst) => ;;; primitive defined (exported) within the compiled libraries (lambda (p) + (unless (pair? p) + (error who "~s exports of ~s" p x)) (let ([label (cdr p)]) (cond [(assq label env) => diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index decc0a8..f3eac81 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -38,7 +38,7 @@ (K dirty-word))) (define (smart-dirty-vector-set addr what) - (record-case what + (struct-case what [(constant t) (if (or (fixnum? t) (immediate? t)) (prm 'nop) @@ -52,7 +52,7 @@ (dirty-vector-set t)))) (define (smart-mem-assign what v x i) - (record-case what + (struct-case what [(constant t) (if (or (fixnum? t) (immediate? t)) (prm 'mset x (K i) v) @@ -150,7 +150,7 @@ (define-primop $memq safe [(P x ls) - (record-case ls + (struct-case ls [(constant ls) (cond [(not (list? ls)) (interrupt)] @@ -167,7 +167,7 @@ (f (cdr ls)))])))])] [else (interrupt)])] [(V x ls) - (record-case ls + (struct-case ls [(constant ls) (cond [(not (list? ls)) (interrupt)] @@ -311,7 +311,7 @@ (interrupt-unless (prm 'u< (T idx) len)) (with-tmp ([t (prm 'logor len (T idx))]) (interrupt-unless-fixnum t))))) - (record-case idx + (struct-case idx [(constant i) (if (and (fixnum? i) (fx>= i 0)) (check-fx i) @@ -325,7 +325,7 @@ (define-primop $make-vector unsafe [(V len) - (record-case len + (struct-case len [(constant i) (unless (fixnum? i) (interrupt)) (with-tmp ([v (prm 'alloc @@ -346,7 +346,7 @@ (define-primop $vector-ref unsafe [(V x i) (or - (record-case i + (struct-case i [(constant i) (and (fixnum? i) (fx>= i 0) @@ -387,7 +387,7 @@ (define-primop $vector-set! unsafe [(E x i v) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (mem-assign v (T x) @@ -433,7 +433,7 @@ (define-primop $cpref unsafe [(V x i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'mref (T x) @@ -502,7 +502,7 @@ (define-primop top-level-value safe [(V x) - (record-case x + (struct-case x [(constant s) (if (symbol? s) (with-tmp ([v (cogen-value-$symbol-value x)]) @@ -516,7 +516,7 @@ (interrupt-when (cogen-pred-$unbound-object? v)) v))])] [(E x) - (record-case x + (struct-case x [(constant s) (if (symbol? s) (with-tmp ([v (cogen-value-$symbol-value x)]) @@ -607,12 +607,12 @@ (define-primop $fx* unsafe [(V a b) - (record-case a + (struct-case a [(constant a) (unless (fixnum? a) (interrupt)) (prm 'int* (T b) (K a))] [else - (record-case b + (struct-case b [(constant b) (unless (fixnum? b) (interrupt)) (prm 'int* (T a) (K b))] @@ -648,7 +648,7 @@ (define-primop $fxsll unsafe [(V x i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'sll (T x) (K i))] @@ -659,7 +659,7 @@ (define-primop $fxsra unsafe [(V x i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'logand @@ -744,7 +744,7 @@ (define-primop $bignum-byte-ref unsafe [(V s i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'sll @@ -799,7 +799,7 @@ (define-primop $flonum-u8-ref unsafe [(V s i) - (record-case i + (struct-case i [(constant i) (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7)) (interrupt)) @@ -823,7 +823,7 @@ (define-primop $flonum-set! unsafe [(E x i v) - (record-case i + (struct-case i [(constant i) (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7)) (interrupt)) @@ -892,7 +892,7 @@ (section ;;; generic arithmetic (define (non-fixnum? x) - (record-case x + (struct-case x [(constant i) (not (fixnum? i))] [else #f])) @@ -1019,7 +1019,7 @@ (define-primop quotient safe [(V x n) - (record-case n + (struct-case n [(constant i) (if (eqv? i 2) (seq* @@ -1039,13 +1039,13 @@ /section) -(section ;;; records +(section ;;; structs -(define-primop $record? unsafe +(define-primop $struct? unsafe [(P x) (sec-tag-test (T x) vector-mask vector-tag vector-mask vector-tag)] [(E x) (nop)]) -(define-primop $record/rtd? unsafe +(define-primop $struct/rtd? unsafe [(P x rtd) (make-conditional (tag-test (T x) vector-mask vector-tag) @@ -1053,36 +1053,36 @@ (make-constant #f))] [(E x rtd) (nop)]) -(define-primop $make-record unsafe +(define-primop $make-struct unsafe [(V rtd len) - (record-case len + (struct-case len [(constant i) (unless (fixnum? i) (interrupt)) (with-tmp ([t (prm 'alloc - (K (align (+ (* i wordsize) disp-record-data))) + (K (align (+ (* i wordsize) disp-struct-data))) (K vector-tag))]) - (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd)) + (prm 'mset t (K (- disp-struct-rtd vector-tag)) (T rtd)) t)] [else - (with-tmp ([ln (align-code len disp-record-data)]) + (with-tmp ([ln (align-code len disp-struct-data)]) (with-tmp ([t (prm 'alloc ln (K vector-tag))]) - (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd)) + (prm 'mset t (K (- disp-struct-rtd vector-tag)) (T rtd)) t))])] [(P rtd len) (K #t)] [(E rtd len) (nop)]) -(define-primop $record-rtd unsafe +(define-primop $struct-rtd unsafe [(V x) - (prm 'mref (T x) (K (- disp-record-rtd vector-tag)))] + (prm 'mref (T x) (K (- disp-struct-rtd vector-tag)))] [(E x) (nop)] [(P x) #t]) -(define-primop $record-ref unsafe +(define-primop $struct-ref unsafe [(V x i) (cogen-value-$vector-ref x i)] [(E x i) (cogen-effect-$vector-ref x i)] [(P x i) (cogen-pred-$vector-ref x i)]) -(define-primop $record-set! unsafe +(define-primop $struct-set! unsafe [(V x i v) (seq* (cogen-effect-$vector-set! x i v) (K void-object))] @@ -1091,16 +1091,16 @@ (seq* (cogen-effect-$vector-set! x i v) (K #t))]) -(define-primop $record unsafe +(define-primop $struct unsafe [(V rtd . v*) (with-tmp ([t (prm 'alloc (K (align - (+ disp-record-data + (+ disp-struct-data (* (length v*) wordsize)))) (K vector-tag))]) - (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd)) + (prm 'mset t (K (- disp-struct-rtd vector-tag)) (T rtd)) (let f ([v* v*] - [i (- disp-record-data vector-tag)]) + [i (- disp-struct-data vector-tag)]) (cond [(null? v*) t] [else @@ -1112,6 +1112,8 @@ /section) + + (section ;;; characters (define-primop char? safe @@ -1152,7 +1154,7 @@ [(E x) (nop)]) (define (non-char? x) - (record-case x + (struct-case x [(constant i) (not (char? i))] [else #f])) @@ -1227,7 +1229,7 @@ (define-primop $make-bytevector unsafe [(V n) - (record-case n + (struct-case n [(constant n) (unless (fixnum? n) (interrupt)) (with-tmp ([s (prm 'alloc @@ -1265,7 +1267,7 @@ (define-primop $bytevector-u8-ref unsafe [(V s i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'sll @@ -1288,7 +1290,7 @@ (define-primop $bytevector-s8-ref unsafe [(V s i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'sra @@ -1314,10 +1316,10 @@ (define-primop $bytevector-set! unsafe [(E x i c) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) - (record-case c + (struct-case c [(constant c) (unless (fixnum? c) (interrupt)) (prm 'bset/c (T x) @@ -1331,7 +1333,7 @@ (K (+ i (- disp-bytevector-data bytevector-tag))) (prm 'sll (T c) (K (- 8 fx-shift))))])] [else - (record-case c + (struct-case c [(constant c) (unless (fixnum? c) (interrupt)) (prm 'bset/c (T x) @@ -1359,7 +1361,7 @@ (define-primop $make-string unsafe [(V n) - (record-case n + (struct-case n [(constant n) (unless (fixnum? n) (interrupt)) (with-tmp ([s (prm 'alloc @@ -1388,7 +1390,7 @@ (define-primop $string-ref unsafe [(V s i) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'mref (T s) @@ -1402,13 +1404,13 @@ [(E s i) (nop)]) (define (assert-fixnum x) - (record-case x + (struct-case x [(constant i) (if (fixnum? i) (nop) (interrupt))] [else (interrupt-unless (cogen-pred-fixnum? x))])) (define (assert-string x) - (record-case x + (struct-case x [(constant s) (if (string? s) (nop) (interrupt))] [else (interrupt-unless (cogen-pred-string? x))])) @@ -1434,7 +1436,7 @@ (define-primop $string-set! unsafe [(E x i c) - (record-case i + (struct-case i [(constant i) (unless (fixnum? i) (interrupt)) (prm 'mset (T x) diff --git a/src/pass-specify-rep.ss b/src/pass-specify-rep.ss index 1b623e3..417fdf1 100644 --- a/src/pass-specify-rep.ss +++ b/src/pass-specify-rep.ss @@ -31,7 +31,7 @@ (module (specify-representation) (import object-representation) (import primops) - (define-record PH + (define-struct PH (interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?)) (define interrupt-handler (make-parameter (lambda () (error 'interrupt-handler "uninitialized")))) @@ -66,21 +66,21 @@ [(not interrupted?) body] [(eq? ctxt 'V) (let ([h (make-interrupt-call x args)]) - (if (record-case body + (if (struct-case body [(primcall op) (eq? op 'interrupt)] [else #f]) (make-no-interrupt-call x args) (make-shortcut body h)))] [(eq? ctxt 'E) (let ([h (make-interrupt-call x args)]) - (if (record-case body + (if (struct-case body [(primcall op) (eq? op 'interrupt)] [else #f]) (make-no-interrupt-call x args) (make-shortcut body h)))] [(eq? ctxt 'P) (let ([h (prm '!= (make-interrupt-call x args) (K bool-f))]) - (if (record-case body + (if (struct-case body [(primcall op) (eq? op 'interrupt)] [else #f]) (prm '!= (make-no-interrupt-call x args) (K bool-f)) @@ -132,7 +132,7 @@ (make-bind lhs* rhs* (k args))]))) (define (cogen-primop x ctxt args) (define (interrupt? x) - (record-case x + (struct-case x [(primcall x) (eq? x 'interrupt)] [else #f])) (let ([p (get-primop x)]) @@ -235,7 +235,7 @@ (define (handle-fix lhs* rhs* body) (define (closure-size x) - (record-case x + (struct-case x [(closure code free*) (if (null? free*) 0 @@ -254,7 +254,7 @@ [else (values a* b* (cons x c*) (cons y d*))]))])) (define (combinator? lhs rhs) - (record-case rhs + (struct-case rhs [(closure code free*) (null? free*)])) (define (sum n* n) (cond @@ -279,7 +279,7 @@ body))))) (define (build-setters lhs* rhs* body) (define (build-setter lhs rhs body) - (record-case rhs + (struct-case rhs [(closure code free*) (make-seq (prm 'mset lhs @@ -325,7 +325,7 @@ [else (make-constant (make-object c))]))) (define (V x) - (record-case x + (struct-case x [(constant) (constant-rep x)] [(var) x] [(primref name) @@ -353,7 +353,7 @@ [else (error 'cogen-V "invalid value expr ~s" x)])) (define (P x) - (record-case x + (struct-case x [(constant c) (if c (K #t) (K #f))] [(primref) (K #t)] [(code-loc) (K #t)] @@ -375,7 +375,7 @@ [else (error 'cogen-P "invalid pred expr ~s" x)])) (define (E x) - (record-case x + (struct-case x [(constant) (nop)] [(var) (nop)] [(primref) (nop)] @@ -411,12 +411,12 @@ x) (V (make-funcall (make-primref 'error) (list (K 'apply) (K "~s is not a procedure") x)))))) - (record-case x + (struct-case x [(primcall op args) (cond [(and (eq? op 'top-level-value) (= (length args) 1) - (record-case (car args) + (struct-case (car args) [(constant t) (and (symbol? t) t)] [else #f])) => @@ -449,19 +449,19 @@ (define (T x) - (record-case x + (struct-case x [(var) x] [(constant i) (constant-rep x)] [else (error 'cogen-T "invalid ~s" (unparse x))])) (define (ClambdaCase x) - (record-case x + (struct-case x [(clambda-case info body) (make-clambda-case info (V body))] [else (error 'specify-rep "invalid clambda-case ~s" x)])) ;;; (define (Clambda x) - (record-case x + (struct-case x [(clambda label case* free* name) (make-clambda label (map ClambdaCase case*) @@ -469,7 +469,7 @@ [else (error 'specify-rep "invalid clambda ~s" x)])) ;;; (define (Program x) - (record-case x + (struct-case x [(codes code* body) (let ([code* (map Clambda code*)] [body (V body)]) diff --git a/src/psyntax.compat.ss b/src/psyntax.compat.ss index d6d17cf..b9ab50f 100644 --- a/src/psyntax.compat.ss +++ b/src/psyntax.compat.ss @@ -1,20 +1,20 @@ (library (psyntax compat) (export define-record make-parameter parameterize format gensym - eval-core make-record-type symbol-value set-symbol-value! - file-options-spec) + eval-core symbol-value set-symbol-value! + file-options-spec make-struct-type) (import (only (ikarus compiler) eval-core) - (rename (ikarus) (define-record sys.define-record))) + (ikarus)) (define-syntax define-record (syntax-rules () [(_ name (field* ...) printer) (begin - (sys.define-record name (field* ...)) + (define-struct name (field* ...)) (module () (set-rtd-printer! (type-descriptor name) printer)))] [(_ name (field* ...)) - (sys.define-record name (field* ...))]))) + (define-struct name (field* ...))]))) diff --git a/src/psyntax.config.ss b/src/psyntax.config.ss index 5d3bf25..49b9011 100644 --- a/src/psyntax.config.ss +++ b/src/psyntax.config.ss @@ -19,7 +19,8 @@ ;;; DEALINGS IN THE SOFTWARE. (library (psyntax config) - (export if-wants-define-record if-wants-case-lambda + (export if-wants-define-record if-wants-define-struct + if-wants-case-lambda if-wants-letrec* if-wants-global-defines) (import (rnrs)) (define-syntax define-option @@ -34,6 +35,7 @@ ((_ sk fk) fk)))))) (define-option if-wants-define-record #t) + (define-option if-wants-define-struct #t) ;;; define-record is an ikarus-specific extension. ;;; should be disabled for all other implementations ;;; the source is included to illustrate how diff --git a/src/psyntax.expander.ss b/src/psyntax.expander.ss index 827cdcc..9693f11 100644 --- a/src/psyntax.expander.ss +++ b/src/psyntax.expander.ss @@ -1325,8 +1325,9 @@ `(syntax-case (list ,@rhs*) () (,lhs* (syntax ,v)))))))))) - (define define-record-macro - (if-wants-define-record + + (define define-struct-macro + (if-wants-define-struct (lambda (e) (define enumerate (lambda (ls) @@ -1342,7 +1343,7 @@ (let* ((namestr (symbol->string (id->sym name))) (fields (map id->sym field*)) (fieldstr* (map symbol->string fields)) - (rtd (datum->stx name (make-record-type namestr fields))) + (rtd (datum->stx name (make-struct-type namestr fields))) (constr (mkid name (string-append "make-" namestr))) (pred (mkid name (string-append namestr "?"))) (i* (enumerate field*)) @@ -1359,29 +1360,30 @@ (define-syntax ,name (cons '$rtd ',rtd)) (define ,constr (lambda ,field* - ($record ',rtd ,@field*))) + ($struct ',rtd ,@field*))) (define ,pred - (lambda (x) ($record/rtd? x ',rtd))) + (lambda (x) ($struct/rtd? x ',rtd))) ,@(map (lambda (getter i) `(define ,getter (lambda (x) - (if ($record/rtd? x ',rtd) - ($record-ref x ,i) + (if ($struct/rtd? x ',rtd) + ($struct-ref x ,i) (error ',getter - "~s is not a record of type ~s" + "~s is not a struct of type ~s" x ',rtd))))) getters i*) ,@(map (lambda (setter i) `(define ,setter (lambda (x v) - (if ($record/rtd? x ',rtd) - ($record-set! x ,i v) + (if ($struct/rtd? x ',rtd) + ($struct-set! x ,i v) (error ',setter - "~s is not a record of type ~s" + "~s is not a struct of type ~s" x ',rtd))))) setters i*))))))) (lambda (stx) - (stx-error stx "define-record not supported")))) + (stx-error stx "define-struct not supported")))) + (define incorrect-usage-macro (lambda (e) (stx-error e "incorrect usage of auxilary keyword"))) @@ -1899,7 +1901,7 @@ ((procedure? x) x) ((symbol? x) (case x - ((define-record) define-record-macro) + ((define-struct) define-struct-macro) ((include) include-macro) ((cond) cond-macro) ((let) let-macro)