diff --git a/lib/ikarus.boot b/lib/ikarus.boot index 7063f0b..a2873d5 100644 Binary files a/lib/ikarus.boot and b/lib/ikarus.boot differ diff --git a/lib/libcore.ss b/lib/libcore.ss index 4b05625..6c325d8 100644 --- a/lib/libcore.ss +++ b/lib/libcore.ss @@ -956,40 +956,6 @@ reference-implementation: (error 'list-ref "~s is not a valid index" index)) (f list index))) - - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; ($apply f (fix arg arg*))))) -; - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; (let ([args (fix arg arg*)]) -; ($apply f args))))) - (primitive-set! 'apply (let () (define (err f ls) @@ -1055,6 +1021,34 @@ reference-implementation: (lambda (x ls) (race x ls ls ls)))) +(primitive-set! 'assv + (letrec ([race + (lambda (x h t ls) + (if (pair? h) + (let ([a ($car h)] [h ($cdr h)]) + (if (pair? a) + (if (eqv? ($car a) x) + a + (if (pair? h) + (if (not (eq? h t)) + (let ([a ($car h)]) + (if (pair? a) + (if (eqv? ($car a) x) + a + (race x ($cdr h) ($cdr t) ls)) + (error 'assv "malformed alist ~s" + ls))) + (error 'assv "circular list ~s" ls)) + (if (null? h) + #f + (error 'assv "~s is not a proper list" ls)))) + (error 'assv "malformed alist ~s" ls))) + (if (null? h) + #f + (error 'assv "~s is not a proper list" ls))))]) + (lambda (x ls) + (race x ls ls ls)))) + (primitive-set! 'assoc (letrec ([race (lambda (x h t ls) diff --git a/lib/makefile.ss b/lib/makefile.ss index 7bf7e65..8407d75 100755 --- a/lib/makefile.ss +++ b/lib/makefile.ss @@ -31,117 +31,85 @@ (define public-primitives - '(null? pair? char? fixnum? symbol? gensym? string? vector? list? - boolean? procedure? - not - eof-object eof-object? bwp-object? - void - fx= fx< fx<= fx> fx>= fxzero? - fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo - fxsll fxsra fxlognot fxlogor fxlogand fxlogxor - integer->char char->integer - char=? char? char>=? - cons car cdr set-car! set-cdr! - caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - list list* make-list length list-ref - append - make-vector vector-ref vector-set! vector-length vector - vector->list list->vector - make-string string-ref string-set! string-length string list->string - uuid - string-append substring - string=? string? string>=? - remprop putprop getprop property-list - apply - map for-each andmap ormap - memq memv assq assoc - eq? eqv? equal? - reverse - string->symbol symbol->string oblist - top-level-value set-top-level-value! top-level-bound? - gensym gensym-count gensym-prefix print-gensym - gensym->unique-string - call-with-values values - make-parameter dynamic-wind - display write print-graph fasl-write printf format print-error - read-token read comment-handler - error exit call/cc - error-handler - eval current-eval interpret compile compile-file new-cafe load - system - expand sc-expand current-expand expand-mode - environment? interaction-environment - identifier? free-identifier=? bound-identifier=? literal-identifier=? + '( + + null? pair? char? fixnum? symbol? gensym? string? vector? list? + boolean? procedure? not eof-object eof-object? bwp-object? + void fx= fx< fx<= fx> fx>= fxzero? fx+ fx- fx* fxadd1 fxsub1 + fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor + fxlogand fxlogxor integer->char char->integer char=? char? char>=? cons car cdr set-car! set-cdr! caar + cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar + cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list* + make-list length list-ref append make-vector vector-ref + vector-set! vector-length vector vector->list list->vector + make-string string-ref string-set! string-length string + list->string uuid string-append substring string=? string? string>=? remprop putprop getprop + property-list apply map for-each andmap ormap memq memv assq + assv assoc eq? eqv? equal? reverse string->symbol + symbol->string oblist top-level-value set-top-level-value! + top-level-bound? gensym gensym-count gensym-prefix print-gensym + gensym->unique-string call-with-values values make-parameter + dynamic-wind display write print-graph fasl-write printf format + print-error read-token read comment-handler error exit call/cc + error-handler eval current-eval interpret compile compile-file + new-cafe load system expand sc-expand current-expand expand-mode + environment? interaction-environment identifier? + free-identifier=? bound-identifier=? literal-identifier=? datum->syntax-object syntax-object->datum syntax-error - syntax->list - generate-temporaries - record? record-set! record-ref record-length - record-type-descriptor make-record-type + syntax->list generate-temporaries record? record-set! record-ref + record-length record-type-descriptor make-record-type record-printer record-name record-field-accessor record-field-mutator record-predicate record-constructor - record-type-name record-type-symbol record-type-field-names + record-type-name record-type-symbol record-type-field-names hash-table? make-hash-table get-hash-table put-hash-table! - assembler-output - $make-environment - features command-line-arguments - - port? input-port? output-port? + assembler-output $make-environment features + command-line-arguments port? input-port? output-port? make-input-port make-output-port make-input/output-port - port-handler - port-input-buffer port-input-index port-input-size - port-output-buffer port-output-index port-output-size - set-port-input-index! set-port-input-size! - set-port-output-index! set-port-output-size! - port-name input-port-name output-port-name - write-char read-char unread-char peek-char - newline - reset-input-port! flush-output-port - close-input-port close-output-port - console-input-port current-input-port - standard-output-port standard-error-port - console-output-port current-output-port - open-output-file open-input-file - open-output-string get-output-string - with-output-to-file call-with-output-file - with-input-from-file call-with-input-file - date-string - file-exists? delete-file - - + - add1 sub1 * expt number? positive? negative? zero? number->string - logand - = < > <= >= - )) + port-handler port-input-buffer port-input-index port-input-size + port-output-buffer port-output-index port-output-size + set-port-input-index! set-port-input-size! + set-port-output-index! set-port-output-size! port-name + input-port-name output-port-name write-char read-char + unread-char peek-char newline reset-input-port! + flush-output-port close-input-port close-output-port + console-input-port current-input-port standard-output-port + standard-error-port console-output-port current-output-port + open-output-file open-input-file open-output-string + get-output-string with-output-to-file call-with-output-file + with-input-from-file call-with-input-file date-string + file-exists? delete-file + - add1 sub1 * expt number? positive? + negative? zero? number->string logand = < > <= >=)) (define system-primitives '( -$closure-code - immediate? $unbound-object? $forward-ptr? pointer-value - primitive-ref primitive-set! $fx= $fx< $fx<= $fx> $fx>= - $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient + + $closure-code immediate? $unbound-object? $forward-ptr? + pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx> + $fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char< $char<= $char> $char>= $car $cdr $set-car! $set-cdr! $make-vector $vector-ref $vector-set! $vector-length - $make-string $string-ref $string-set! $string-length $string + $make-string $string-ref $string-set! $string-length $string $symbol-string $symbol-unique-string $symbol-value $set-symbol-string! $set-symbol-unique-string! $set-symbol-value! $make-symbol $set-symbol-plist! $symbol-plist $sc-put-cte $record? $record/rtd? $record-set! $record-ref $record-rtd $make-record $record $base-rtd $code? $code-reloc-vector $code-freevars $code-size $code-ref - $code-set! $code->closure list*->code* make-code - code? set-code-reloc-vector! code-reloc-vector code-freevars + $code-set! $code->closure list*->code* make-code code? + set-code-reloc-vector! code-reloc-vector code-freevars code-size code-ref code-set! $frame->continuation $fp-at-base $current-frame $arg-list $seal-frame-and-call $make-call-with-values-procedure $make-values-procedure do-overflow collect $make-tcbucket $tcbucket-next $tcbucket-key - $tcbucket-val $set-tcbucket-next! $set-tcbucket-val! + $tcbucket-val $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! $tcbucket-dlink-prev $tcbucket-dlink-next $set-tcbucket-dlink-prev! $set-tcbucket-dlink-next! call/cf - trace-symbol! untrace-symbol! make-traced-procedure + trace-symbol! untrace-symbol! make-traced-procedure fixnum->string ;;; TODO: must open-code