added assv

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)

lib/makefile.ss

@@ -31,117 +31,85 @@
 
 
 (define public-primitives
-  '(null? pair? char? fixnum? symbol? gensym? string? vector? list?
+  '(
-    boolean? procedure? 
+    
-    not
+    null? pair? char? fixnum? symbol? gensym? string? vector? list?
-    eof-object eof-object? bwp-object?
+    boolean? procedure?  not eof-object eof-object? bwp-object?
-    void
+    void fx= fx< fx<= fx> fx>= fxzero?  fx+ fx- fx* fxadd1 fxsub1
-    fx= fx< fx<= fx> fx>= fxzero?
+    fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
-    fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo 
+    fxlogand fxlogxor integer->char char->integer char=? char<?
-    fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
+    char<=? char>? char>=?  cons car cdr set-car! set-cdr!  caar
-    integer->char char->integer
+    cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
-    char=? char<? char<=? char>? char>=?
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
-    cons car cdr set-car! set-cdr!
+    cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list*
-    caar cadr cdar cddr 
+    make-list length list-ref append make-vector vector-ref
-    caaar caadr cadar caddr cdaar cdadr cddar cdddr 
+    vector-set! vector-length vector vector->list list->vector
-    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
+    make-string string-ref string-set! string-length string
-    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 
+    list->string uuid string-append substring string=? string<?
-    list list* make-list length list-ref
+    string<=? string>? string>=?  remprop putprop getprop
-    append
+    property-list apply map for-each andmap ormap memq memv assq
-    make-vector vector-ref vector-set! vector-length vector
+    assv assoc eq? eqv? equal?  reverse string->symbol
-    vector->list list->vector
+    symbol->string oblist top-level-value set-top-level-value!
-    make-string string-ref string-set! string-length string list->string
+    top-level-bound?  gensym gensym-count gensym-prefix print-gensym
-    uuid
+    gensym->unique-string call-with-values values make-parameter
-    string-append substring 
+    dynamic-wind display write print-graph fasl-write printf format
-    string=? string<? string<=? string>? string>=?
+    print-error read-token read comment-handler error exit call/cc
-    remprop putprop getprop property-list
+    error-handler eval current-eval interpret compile compile-file
-    apply
+    new-cafe load system expand sc-expand current-expand expand-mode
-    map for-each andmap ormap
+    environment? interaction-environment identifier?
-    memq memv assq assoc
+    free-identifier=? bound-identifier=? literal-identifier=?
-    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
+    syntax->list generate-temporaries record? record-set! record-ref
-    generate-temporaries
+    record-length record-type-descriptor make-record-type
-    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
     hash-table? make-hash-table get-hash-table put-hash-table!
-    assembler-output
+    assembler-output $make-environment features
-    $make-environment
+    command-line-arguments port? input-port? output-port?
-    features command-line-arguments
-
-    port? input-port? output-port? 
     make-input-port make-output-port make-input/output-port
-    port-handler
+    port-handler port-input-buffer port-input-index port-input-size
-    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!
+    set-port-output-index! set-port-output-size!  port-name
-    port-name input-port-name output-port-name
+    input-port-name output-port-name write-char read-char
-    write-char read-char unread-char peek-char
+    unread-char peek-char newline reset-input-port!
-    newline 
+    flush-output-port close-input-port close-output-port
-    reset-input-port! flush-output-port
+    console-input-port current-input-port standard-output-port
-    close-input-port close-output-port
+    standard-error-port console-output-port current-output-port
-    console-input-port current-input-port
+    open-output-file open-input-file open-output-string
-    standard-output-port standard-error-port
+    get-output-string with-output-to-file call-with-output-file
-    console-output-port current-output-port
+    with-input-from-file call-with-input-file date-string
-    open-output-file open-input-file
+    file-exists? delete-file + - add1 sub1 * expt number? positive?
-    open-output-string get-output-string
+    negative? zero? number->string logand = < > <= >=))
-    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
+    $closure-code immediate? $unbound-object? $forward-ptr?
-    primitive-ref primitive-set!  $fx= $fx< $fx<= $fx> $fx>=
+    pointer-value primitive-ref primitive-set!  $fx= $fx< $fx<= $fx>
-    $fxzero?  $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
+    $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->closure list*->code* make-code code?
-    code?  set-code-reloc-vector! code-reloc-vector code-freevars
+    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