1725 lines
51 KiB
Scheme
1725 lines
51 KiB
Scheme
|
|
;;; 6.9: * removed uuid
|
|
;;; * top-level-value is now open-coded.
|
|
;;;
|
|
;;; 6.2: * added bwp-object?, weak-cons, weak-pair?
|
|
;;; * pointer-value
|
|
;;; 6.1: * added uses of case-lambda to replace the ugly code
|
|
;;; 6.0: * basic version working
|
|
|
|
|
|
(primitive-set! 'call-with-values
|
|
($make-call-with-values-procedure))
|
|
|
|
(primitive-set! 'values
|
|
($make-values-procedure))
|
|
|
|
(primitive-set! 'exit
|
|
(case-lambda
|
|
[() (exit 0)]
|
|
[(status) (foreign-call "exit" status)]))
|
|
|
|
(primitive-set! 'eof-object
|
|
(lambda () (eof-object)))
|
|
|
|
(primitive-set! 'void
|
|
(lambda () (void)))
|
|
|
|
(primitive-set! 'eof-object?
|
|
(lambda (x) (eof-object? x)))
|
|
|
|
(primitive-set! 'fxadd1
|
|
(lambda (n)
|
|
(fxadd1 n)))
|
|
|
|
(primitive-set! 'fxsub1
|
|
(lambda (n)
|
|
(fxsub1 n)))
|
|
|
|
(primitive-set! 'integer->char
|
|
(lambda (n)
|
|
(unless (fixnum? n)
|
|
(error 'integer->char "~s is not a fixnum" n))
|
|
(unless (and ($fx>= n 0)
|
|
($fx<= n 255))
|
|
(error 'integer->char "~s is out of range[0..255]" n))
|
|
($fixnum->char n)))
|
|
|
|
(primitive-set! 'char->integer
|
|
(lambda (x)
|
|
(unless (char? x)
|
|
(error 'char->integer "~s is not a character" x))
|
|
($char->fixnum x)))
|
|
|
|
(primitive-set! 'fxlognot
|
|
(lambda (x)
|
|
(unless (fixnum? x)
|
|
(error 'fxlognot "~s is not a fixnum" x))
|
|
($fxlognot x)))
|
|
|
|
(primitive-set! 'fixnum? (lambda (x) (fixnum? x)))
|
|
(primitive-set! 'immediate? (lambda (x) (immediate? x)))
|
|
|
|
(primitive-set! 'fxzero?
|
|
(lambda (x)
|
|
(unless (fixnum? x)
|
|
(error 'fxzero? "~s is not a fixnum" x))
|
|
($fxzero? x)))
|
|
|
|
(primitive-set! 'boolean? (lambda (x) (boolean? x)))
|
|
|
|
(primitive-set! 'char? (lambda (x) (char? x)))
|
|
|
|
(primitive-set! 'vector? (lambda (x) (vector? x)))
|
|
|
|
(primitive-set! 'string? (lambda (x) (string? x)))
|
|
|
|
(primitive-set! 'procedure? (lambda (x) (procedure? x)))
|
|
|
|
(primitive-set! 'null? (lambda (x) (null? x)))
|
|
|
|
(primitive-set! 'pair? (lambda (x) (pair? x)))
|
|
|
|
(let ()
|
|
(define fill!
|
|
(lambda (v i n fill)
|
|
(cond
|
|
[($fx= i n) v]
|
|
[else
|
|
($vector-set! v i fill)
|
|
(fill! v ($fx+ i 1) n fill)])))
|
|
(define make-vector
|
|
(case-lambda
|
|
[(n) (make-vector n (void))]
|
|
[(n fill)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
(error 'make-vector "~s is not a valid length" n))
|
|
(fill! ($make-vector n) 0 n fill)]))
|
|
(primitive-set! 'make-vector make-vector))
|
|
|
|
(primitive-set! 'vector-length
|
|
(lambda (x)
|
|
(unless (vector? x)
|
|
(error 'vector-length "~s is not a vector" x))
|
|
($vector-length x)))
|
|
|
|
(let ()
|
|
(define fill!
|
|
(lambda (s i n c)
|
|
(cond
|
|
[($fx= i n) s]
|
|
[else
|
|
($string-set! s i c)
|
|
(fill! s ($fx+ i 1) n c)])))
|
|
(define make-string
|
|
(case-lambda
|
|
[(n)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
(error 'make-string "~s is not a valid length" n))
|
|
($make-string n)]
|
|
[(n c)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
(error 'make-string "~s is not a valid length" n))
|
|
(unless (char? c)
|
|
(error 'make-string "~s is not a character" c))
|
|
(fill! ($make-string n) 0 n c)]))
|
|
(primitive-set! 'make-string make-string))
|
|
|
|
|
|
(primitive-set! 'string-length
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(error 'string-length "~s is not a string" x))
|
|
($string-length x)))
|
|
|
|
(primitive-set! 'string->list
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(error 'string->list "~s is not a string" x))
|
|
(let f ([x x] [i ($string-length x)] [ac '()])
|
|
(cond
|
|
[($fxzero? i) ac]
|
|
[else
|
|
(let ([i ($fxsub1 i)])
|
|
(f x i (cons ($string-ref x i) ac)))]))))
|
|
|
|
#|procedure:string=?
|
|
synopsis:
|
|
(string=? s s* ...)
|
|
description:
|
|
string=? takes 1 or more strings and returns #t if all strings are
|
|
equal. Two strings s1 and s2 are string=? if they have the same
|
|
length and if (char=? (string-ref s1 i) (string-ref s2 i)) for all
|
|
0 <= i < (string-length s1)
|
|
|#
|
|
(let ()
|
|
(define bstring=?
|
|
(lambda (s1 s2 i j)
|
|
(or ($fx= i j)
|
|
(and ($char= ($string-ref s1 i) ($string-ref s2 i))
|
|
(bstring=? s1 s2 ($fxadd1 i) j)))))
|
|
(define check-strings-and-return-false
|
|
(lambda (s*)
|
|
(cond
|
|
[(null? s*) #f]
|
|
[(string? ($car s*))
|
|
(check-strings-and-return-false ($cdr s*))]
|
|
[else (err ($car s*))])))
|
|
(define strings=?
|
|
(lambda (s s* n)
|
|
(or (null? s*)
|
|
(let ([a ($car s*)])
|
|
(unless (string? a)
|
|
(error 'string=? "~s is not a string" a))
|
|
(if ($fx= n ($string-length a))
|
|
(and (strings=? s ($cdr s*) n)
|
|
(bstring=? s a 0 n))
|
|
(check-strings-and-return-false ($cdr s*)))))))
|
|
(define (err x)
|
|
(error 'string=? "~s is not a string" x))
|
|
(primitive-set! 'string=?
|
|
(case-lambda
|
|
[(s s1)
|
|
(if (string? s)
|
|
(if (string? s1)
|
|
(let ([n ($string-length s)])
|
|
(and ($fx= n ($string-length s1))
|
|
(bstring=? s s1 0 n)))
|
|
(err s1))
|
|
(err s))]
|
|
[(s . s*)
|
|
(if (string? s)
|
|
(strings=? s s* ($string-length s))
|
|
(err s))])))
|
|
|
|
#|procedure:string-append
|
|
synopsis:
|
|
(string-append str ...)
|
|
description:
|
|
Takes 0 or more strings and returns a new string that results from
|
|
appending the contents of the strings together.
|
|
reference-implementation:
|
|
(define (string-append . s*)
|
|
(list->string (apply append (map string->list s*))))
|
|
|#
|
|
(let ()
|
|
;; FIXME: make nonconsing on 0,1,2, and 3 args
|
|
(define length*
|
|
(lambda (s* n)
|
|
(cond
|
|
[(null? s*) n]
|
|
[else
|
|
(let ([a ($car s*)])
|
|
(unless (string? a)
|
|
(error 'string-append "~s is not a string" a))
|
|
(length* ($cdr s*) ($fx+ n ($string-length a))))])))
|
|
(define fill-string
|
|
(lambda (s a si sj ai)
|
|
(unless ($fx= si sj)
|
|
($string-set! s si ($string-ref a ai))
|
|
(fill-string s a ($fxadd1 si) sj ($fxadd1 ai)))))
|
|
(define fill-strings
|
|
(lambda (s s* i)
|
|
(cond
|
|
[(null? s*) s]
|
|
[else
|
|
(let ([a ($car s*)])
|
|
(let ([n ($string-length a)])
|
|
(let ([j ($fx+ i n)])
|
|
(fill-string s a i j 0)
|
|
(fill-strings s ($cdr s*) j))))])))
|
|
(primitive-set! 'string-append
|
|
(lambda s*
|
|
(let ([n (length* s* 0)])
|
|
(let ([s ($make-string n)])
|
|
(fill-strings s s* 0))))))
|
|
|
|
#|procedure:substring
|
|
(substring str i j)
|
|
Returns a substring of str starting from index i (inclusive)
|
|
and ending with index j (exclusive).|#
|
|
(let ()
|
|
(define fill
|
|
(lambda (s d si sj di)
|
|
(cond
|
|
[($fx= si sj) d]
|
|
[else
|
|
($string-set! d di ($string-ref s si))
|
|
(fill s d ($fxadd1 si) sj ($fxadd1 di))])))
|
|
(primitive-set! 'substring
|
|
(lambda (s n m)
|
|
(unless (string? s)
|
|
(error 'substring "~s is not a string" s))
|
|
(let ([len ($string-length s)])
|
|
(unless (and (fixnum? n)
|
|
($fx>= n 0)
|
|
($fx< n len))
|
|
(error 'substring "~s is not a valid start index for ~s" n s))
|
|
(unless (and (fixnum? m)
|
|
($fx>= m 0)
|
|
($fx<= m len))
|
|
(error 'substring "~s is not a valid end index for ~s" m s))
|
|
(let ([len ($fx- m n)])
|
|
(if ($fx<= len 0)
|
|
""
|
|
(fill s ($make-string len) n m 0)))))))
|
|
|
|
(primitive-set! 'not (lambda (x) (not x)))
|
|
|
|
(primitive-set! 'symbol->string
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'symbol->string "~s is not a symbol" x))
|
|
(let ([str ($symbol-string x)])
|
|
(or str
|
|
(let ([ct (gensym-count)])
|
|
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
|
|
($set-symbol-string! x str)
|
|
(gensym-count ($fxadd1 ct))
|
|
str))))))
|
|
|
|
(primitive-set! 'gensym?
|
|
(lambda (x)
|
|
(and (symbol? x)
|
|
(let ([s ($symbol-unique-string x)])
|
|
(and s #t)))))
|
|
|
|
(let ()
|
|
(define f
|
|
(lambda (n i j)
|
|
(cond
|
|
[($fxzero? n)
|
|
(values (make-string i) j)]
|
|
[else
|
|
(let ([q ($fxquotient n 10)])
|
|
(call-with-values
|
|
(lambda () (f q ($fxadd1 i) j))
|
|
(lambda (str j)
|
|
(let ([r ($fx- n ($fx* q 10))])
|
|
(string-set! str j
|
|
($fixnum->char ($fx+ r ($char->fixnum #\0))))
|
|
(values str ($fxadd1 j))))))])))
|
|
(primitive-set! 'fixnum->string
|
|
(lambda (x)
|
|
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
|
|
(cond
|
|
[($fxzero? x) "0"]
|
|
[($fx> x 0)
|
|
(call-with-values
|
|
(lambda () (f x 0 0))
|
|
(lambda (str j) str))]
|
|
[($fx= x -536870912) "-536870912"]
|
|
[else
|
|
(call-with-values
|
|
(lambda () (f ($fx- 0 x) 1 1))
|
|
(lambda (str j)
|
|
($string-set! str 0 #\-)
|
|
str))]))))
|
|
|
|
;;; OLD (primitive-set! 'top-level-value
|
|
;;; OLD (lambda (x)
|
|
;;; OLD (unless (symbol? x)
|
|
;;; OLD (error 'top-level-value "~s is not a symbol" x))
|
|
;;; OLD (let ([v ($symbol-value x)])
|
|
;;; OLD (when ($unbound-object? v)
|
|
;;; OLD (error 'top-level-value "unbound variable ~s" x))
|
|
;;; OLD v)))
|
|
|
|
(primitive-set! 'top-level-value
|
|
(lambda (x)
|
|
(top-level-value x)))
|
|
|
|
(primitive-set! 'top-level-bound?
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'top-level-bound? "~s is not a symbol" x))
|
|
(not ($unbound-object? ($symbol-value x)))))
|
|
|
|
(primitive-set! 'set-top-level-value!
|
|
(lambda (x v)
|
|
(unless (symbol? x)
|
|
(error 'set-top-level-value! "~s is not a symbol" x))
|
|
($set-symbol-value! x v)))
|
|
|
|
(primitive-set! 'symbol? (lambda (x) (symbol? x)))
|
|
|
|
(primitive-set! 'primitive?
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'primitive? "~s is not a symbol" x))
|
|
(procedure? (primitive-ref x))))
|
|
|
|
(primitive-set! 'primitive-ref
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'primitive-ref "~s is not a symbol" x))
|
|
(let ([v (primitive-ref x)])
|
|
(unless (procedure? v)
|
|
(error 'primitive-ref "~s is not a primitive" x))
|
|
v)))
|
|
|
|
(primitive-set! 'primitive-set!
|
|
(lambda (x v)
|
|
(unless (symbol? x)
|
|
(error 'primitive-set! "~s is not a symbol" x))
|
|
(primitive-set! x v)
|
|
(set-top-level-value! x v)))
|
|
|
|
|
|
|
|
|
|
|
|
(primitive-set! 'fx+
|
|
(lambda (x y)
|
|
(fx+ x y)))
|
|
|
|
(primitive-set! 'fx-
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx- "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx- "~s is not a fixnum" y))
|
|
($fx- x y)))
|
|
|
|
(primitive-set! 'fx*
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx* "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx* "~s is not a fixnum" y))
|
|
($fx* x y)))
|
|
|
|
|
|
|
|
(primitive-set! 'fxquotient
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxquotient "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxquotient "~s is not a fixnum" y))
|
|
(when ($fxzero? y)
|
|
(error 'fxquotient "zero dividend ~s" y))
|
|
($fxquotient x y)))
|
|
|
|
|
|
(primitive-set! 'fxremainder
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxremainder "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxremainder "~s is not a fixnum" y))
|
|
(when ($fxzero? y)
|
|
(error 'fxremainder "zero dividend ~s" y))
|
|
(let ([q ($fxquotient x y)])
|
|
($fx- x ($fx* q y)))))
|
|
|
|
|
|
(primitive-set! 'fxmodulo
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxmodulo "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxmodulo "~s is not a fixnum" y))
|
|
(when ($fxzero? y)
|
|
(error 'fxmodulo "zero dividend ~s" y))
|
|
($fxmodulo x y)))
|
|
|
|
|
|
(primitive-set! 'fxlogor
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxlogor "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxlogor "~s is not a fixnum" y))
|
|
($fxlogor x y)))
|
|
|
|
(primitive-set! 'fxlogxor
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxlogxor "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxlogxor "~s is not a fixnum" y))
|
|
($fxlogxor x y)))
|
|
|
|
(primitive-set! 'fxlogand
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxlogand "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxlogand "~s is not a fixnum" y))
|
|
($fxlogand x y)))
|
|
|
|
(primitive-set! 'fxsra
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxsra "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxsra "~s is not a fixnum" y))
|
|
(unless ($fx>= y 0)
|
|
(error 'fxsra "negative shift not allowed, got ~s" y))
|
|
($fxsra x y)))
|
|
|
|
(primitive-set! 'fxsll
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fxsll "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fxsll "~s is not a fixnum" y))
|
|
(unless ($fx>= y 0)
|
|
(error 'fxsll "negative shift not allowed, got ~s" y))
|
|
($fxsll x y)))
|
|
|
|
(primitive-set! 'fx=
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx= "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx= "~s is not a fixnum" y))
|
|
($fx= x y)))
|
|
|
|
(primitive-set! 'fx<
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx< "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx< "~s is not a fixnum" y))
|
|
($fx< x y)))
|
|
|
|
(primitive-set! 'fx<=
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx<= "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx<= "~s is not a fixnum" y))
|
|
($fx<= x y)))
|
|
|
|
(primitive-set! 'fx>
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx> "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx> "~s is not a fixnum" y))
|
|
($fx> x y)))
|
|
|
|
(primitive-set! 'fx>=
|
|
(lambda (x y)
|
|
(unless (fixnum? x)
|
|
(error 'fx>= "~s is not a fixnum" x))
|
|
(unless (fixnum? y)
|
|
(error 'fx>= "~s is not a fixnum" y))
|
|
($fx>= x y)))
|
|
|
|
|
|
(primitive-set! 'char=?
|
|
(let ()
|
|
(define (err x)
|
|
(error 'char=? "~s is not a character" x))
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
($char= c1 c2)
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 c2 c3)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(if (char? c3)
|
|
(and ($char= c1 c2)
|
|
($char= c2 c3))
|
|
(err c3))
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 . c*)
|
|
(if (char? c1)
|
|
(let f ([c* c*])
|
|
(or (null? c*)
|
|
(let ([c2 ($car c*)])
|
|
(if (char? c2)
|
|
(if ($char= c1 c2)
|
|
(f ($cdr c*))
|
|
(let g ([c* ($cdr c*)])
|
|
(if (null? c*)
|
|
#f
|
|
(if (char? ($car c*))
|
|
(g ($cdr c*))
|
|
(err ($car c*))))))
|
|
(err c2)))))
|
|
(err c1))])))
|
|
|
|
|
|
(primitive-set! 'char<?
|
|
(let ()
|
|
(define (err x)
|
|
(error 'char<? "~s is not a character" x))
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
($char< c1 c2)
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 c2 c3)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(if (char? c3)
|
|
(and ($char< c1 c2)
|
|
($char< c2 c3))
|
|
(err c3))
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 . c*)
|
|
(if (char? c1)
|
|
(let f ([c1 c1] [c* c*])
|
|
(or (null? c*)
|
|
(let ([c2 ($car c*)])
|
|
(if (char? c2)
|
|
(if ($char< c1 c2)
|
|
(f c2 ($cdr c*))
|
|
(let g ([c* ($cdr c*)])
|
|
(if (null? c*)
|
|
#f
|
|
(if (char? ($car c*))
|
|
(g ($cdr c*))
|
|
(err ($car c*))))))
|
|
(err c2)))))
|
|
(err c1))])))
|
|
|
|
(primitive-set! 'char<=?
|
|
(let ()
|
|
(define (err x)
|
|
(error 'char<=? "~s is not a character" x))
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
($char<= c1 c2)
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 c2 c3)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(if (char? c3)
|
|
(and ($char<= c1 c2)
|
|
($char<= c2 c3))
|
|
(err c3))
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 . c*)
|
|
(if (char? c1)
|
|
(let f ([c1 c1] [c* c*])
|
|
(or (null? c*)
|
|
(let ([c2 ($car c*)])
|
|
(if (char? c2)
|
|
(if ($char<= c1 c2)
|
|
(f c2 ($cdr c*))
|
|
(let g ([c* ($cdr c*)])
|
|
(if (null? c*)
|
|
#f
|
|
(if (char? ($car c*))
|
|
(g ($cdr c*))
|
|
(err ($car c*))))))
|
|
(err c2)))))
|
|
(err c1))])))
|
|
|
|
(primitive-set! 'char>?
|
|
(let ()
|
|
(define (err x)
|
|
(error 'char>? "~s is not a character" x))
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
($char> c1 c2)
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 c2 c3)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(if (char? c3)
|
|
(and ($char> c1 c2)
|
|
($char> c2 c3))
|
|
(err c3))
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 . c*)
|
|
(if (char? c1)
|
|
(let f ([c1 c1] [c* c*])
|
|
(or (null? c*)
|
|
(let ([c2 ($car c*)])
|
|
(if (char? c2)
|
|
(if ($char> c1 c2)
|
|
(f c2 ($cdr c*))
|
|
(let g ([c* ($cdr c*)])
|
|
(if (null? c*)
|
|
#f
|
|
(if (char? ($car c*))
|
|
(g ($cdr c*))
|
|
(err ($car c*))))))
|
|
(err c2)))))
|
|
(err c1))])))
|
|
|
|
(primitive-set! 'char>=?
|
|
(let ()
|
|
(define (err x)
|
|
(error 'char>=? "~s is not a character" x))
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
($char>= c1 c2)
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 c2 c3)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(if (char? c3)
|
|
(and ($char>= c1 c2)
|
|
($char>= c2 c3))
|
|
(err c3))
|
|
(err c2))
|
|
(err c1))]
|
|
[(c1 . c*)
|
|
(if (char? c1)
|
|
(let f ([c1 c1] [c* c*])
|
|
(or (null? c*)
|
|
(let ([c2 ($car c*)])
|
|
(if (char? c2)
|
|
(if ($char>= c1 c2)
|
|
(f c2 ($cdr c*))
|
|
(let g ([c* ($cdr c*)])
|
|
(if (null? c*)
|
|
#f
|
|
(if (char? ($car c*))
|
|
(g ($cdr c*))
|
|
(err ($car c*))))))
|
|
(err c2)))))
|
|
(err c1))])))
|
|
|
|
|
|
(primitive-set! 'cons (lambda (x y) (cons x y)))
|
|
|
|
(primitive-set! 'eq? (lambda (x y) (eq? x y)))
|
|
|
|
(primitive-set! 'eqv?
|
|
(lambda (x y)
|
|
(or (eq? x y)
|
|
(and (number? x) (number? y) (= x y)))))
|
|
|
|
(primitive-set! 'set-car!
|
|
(lambda (x y)
|
|
(unless (pair? x)
|
|
(error 'set-car! "~s is not a pair" x))
|
|
($set-car! x y)))
|
|
|
|
(primitive-set! 'set-cdr!
|
|
(lambda (x y)
|
|
(unless (pair? x)
|
|
(error 'set-cdr! "~s is not a pair" x))
|
|
($set-cdr! x y)))
|
|
|
|
(primitive-set! 'vector-ref
|
|
(lambda (v i)
|
|
(unless (vector? v)
|
|
(error 'vector-ref "~s is not a vector" v))
|
|
(unless (fixnum? i)
|
|
(error 'vector-ref "~s is not a valid index" i))
|
|
(unless (and ($fx< i ($vector-length v))
|
|
($fx<= 0 i))
|
|
(error 'vector-ref "index ~s is out of range for ~s" i v))
|
|
($vector-ref v i)))
|
|
|
|
(primitive-set! 'string-ref
|
|
(lambda (s i)
|
|
(unless (string? s)
|
|
(error 'string-ref "~s is not a string" s))
|
|
(unless (fixnum? i)
|
|
(error 'string-ref "~s is not a valid index" i))
|
|
(unless (and ($fx< i ($string-length s))
|
|
($fx<= 0 i))
|
|
(error 'string-ref "index ~s is out of range for ~s" i s))
|
|
($string-ref s i)))
|
|
|
|
(primitive-set! 'vector-set!
|
|
(lambda (v i c)
|
|
(unless (vector? v)
|
|
(error 'vector-set! "~s is not a vector" v))
|
|
(unless (fixnum? i)
|
|
(error 'vector-set! "~s is not a valid index" i))
|
|
(unless (and ($fx< i ($vector-length v))
|
|
($fx<= 0 i))
|
|
(error 'vector-set! "index ~s is out of range for ~s" i v))
|
|
($vector-set! v i c)))
|
|
|
|
|
|
(primitive-set! 'string-set!
|
|
(lambda (s i c)
|
|
(unless (string? s)
|
|
(error 'string-set! "~s is not a string" s))
|
|
(unless (fixnum? i)
|
|
(error 'string-set! "~s is not a valid index" i))
|
|
(unless (and ($fx< i ($string-length s))
|
|
($fx>= i 0))
|
|
(error 'string-set! "index ~s is out of range for ~s" i s))
|
|
(unless (char? c)
|
|
(error 'string-set! "~s is not a character" c))
|
|
($string-set! s i c)))
|
|
|
|
(primitive-set! 'vector
|
|
;;; FIXME: add case-lambda
|
|
(letrec ([length
|
|
(lambda (ls n)
|
|
(cond
|
|
[(null? ls) n]
|
|
[else (length ($cdr ls) ($fx+ n 1))]))]
|
|
[loop
|
|
(lambda (v ls i n)
|
|
(cond
|
|
[($fx= i n) v]
|
|
[else
|
|
($vector-set! v i ($car ls))
|
|
(loop v ($cdr ls) ($fx+ i 1) n)]))])
|
|
(lambda ls
|
|
(let ([n (length ls 0)])
|
|
(let ([v (make-vector n)])
|
|
(loop v ls 0 n))))))
|
|
|
|
(primitive-set! 'string
|
|
;;; FIXME: add case-lambda
|
|
(letrec ([length
|
|
(lambda (ls n)
|
|
(cond
|
|
[(null? ls) n]
|
|
[(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))]
|
|
[else (error 'string "~s is not a character" ($car ls))]))]
|
|
[loop
|
|
(lambda (s ls i n)
|
|
(cond
|
|
[($fx= i n) s]
|
|
[else
|
|
($string-set! s i ($car ls))
|
|
(loop s ($cdr ls) ($fx+ i 1) n)]))])
|
|
(lambda ls
|
|
(let ([n (length ls 0)])
|
|
(let ([s (make-string n)])
|
|
(loop s ls 0 n))))))
|
|
|
|
(primitive-set! 'list?
|
|
(letrec ([race
|
|
(lambda (h t)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(and (not (eq? h t))
|
|
(race ($cdr h) ($cdr t)))
|
|
(null? h)))
|
|
(null? h)))])
|
|
(lambda (x) (race x x))))
|
|
|
|
|
|
|
|
(primitive-set! 'reverse
|
|
(letrec ([race
|
|
(lambda (h t ls ac)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)] [ac (cons ($car h) ac)])
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
|
|
(error 'reverse "~s is a circular list" ls))
|
|
(if (null? h)
|
|
ac
|
|
(error 'reverse "~s is not a proper list" ls))))
|
|
(if (null? h)
|
|
ac
|
|
(error 'reverse "~s is not a proper list" ls))))])
|
|
(lambda (x)
|
|
(race x x x '()))))
|
|
|
|
(primitive-set! 'memq
|
|
(letrec ([race
|
|
(lambda (h t ls x)
|
|
(if (pair? h)
|
|
(if (eq? ($car h) x)
|
|
h
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eq? ($car h) x)
|
|
h
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls x)
|
|
(error 'memq "circular list ~s" ls)))
|
|
(if (null? h)
|
|
'#f
|
|
(error 'memq "~s is not a proper list" ls)))))
|
|
(if (null? h)
|
|
'#f
|
|
(error 'memq "~s is not a proper list" ls))))])
|
|
(lambda (x ls)
|
|
(race ls ls ls x))))
|
|
|
|
(primitive-set! 'memv
|
|
(letrec ([race
|
|
(lambda (h t ls x)
|
|
(if (pair? h)
|
|
(if (eqv? ($car h) x)
|
|
h
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eqv? ($car h) x)
|
|
h
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls x)
|
|
(error 'memv "circular list ~s" ls)))
|
|
(if (null? h)
|
|
'#f
|
|
(error 'memv "~s is not a proper list" ls)))))
|
|
(if (null? h)
|
|
'#f
|
|
(error 'memv "~s is not a proper list" ls))))])
|
|
(lambda (x ls)
|
|
(race ls ls ls x))))
|
|
|
|
|
|
(primitive-set! 'list->string
|
|
(letrec ([race
|
|
(lambda (h t ls n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
|
|
(error 'reverse "circular list ~s" ls))
|
|
(if (null? h)
|
|
($fx+ n 1)
|
|
(error 'reverse "~s is not a proper list" ls))))
|
|
(if (null? h)
|
|
n
|
|
(error 'reverse "~s is not a proper list" ls))))]
|
|
[fill
|
|
(lambda (s i ls)
|
|
(cond
|
|
[(null? ls) s]
|
|
[else
|
|
(let ([c ($car ls)])
|
|
(unless (char? c)
|
|
(error 'list->string "~s is not a character" c))
|
|
($string-set! s i c)
|
|
(fill s ($fxadd1 i) (cdr ls)))]))])
|
|
(lambda (ls)
|
|
(let ([n (race ls ls ls 0)])
|
|
(let ([s ($make-string n)])
|
|
(fill s 0 ls))))))
|
|
|
|
(primitive-set! 'length
|
|
(letrec ([race
|
|
(lambda (h t ls n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
|
|
(error 'length "circular list ~s" ls))
|
|
(if (null? h)
|
|
($fx+ n 1)
|
|
(error 'length "~s is not a proper list" ls))))
|
|
(if (null? h)
|
|
n
|
|
(error 'length "~s is not a proper list" ls))))])
|
|
(lambda (ls)
|
|
(race ls ls ls 0))))
|
|
|
|
|
|
(primitive-set! 'list-ref
|
|
(lambda (list index)
|
|
(define f
|
|
(lambda (ls i)
|
|
(cond
|
|
[($fxzero? i)
|
|
(if (pair? ls)
|
|
($car ls)
|
|
(error 'list-ref "index ~s is out of range for ~s" index list))]
|
|
[(pair? ls)
|
|
(f ($cdr ls) ($fxsub1 i))]
|
|
[(null? ls)
|
|
(error 'list-rec "index ~s is out of range for ~s" index list)]
|
|
[else (error 'list-ref "~s is not a list" list)])))
|
|
(unless (and (fixnum? index) ($fx>= index 0))
|
|
(error 'list-ref "~s is not a valid index" index))
|
|
(f list index)))
|
|
|
|
(primitive-set! 'apply
|
|
(let ()
|
|
(define (err f ls)
|
|
(if (procedure? f)
|
|
(error 'apply "not a list")
|
|
(error 'apply "~s is not a procedure" f)))
|
|
(define (fixandgo f a0 a1 ls p d)
|
|
(cond
|
|
[(null? ($cdr d))
|
|
(let ([last ($car d)])
|
|
($set-cdr! p last)
|
|
(if (and (procedure? f) (list? last))
|
|
($apply f a0 a1 ls)
|
|
(err f last)))]
|
|
[else (fixandgo f a0 a1 ls d ($cdr d))]))
|
|
(define apply
|
|
(case-lambda
|
|
[(f ls)
|
|
(if (and (procedure? f) (list? ls))
|
|
($apply f ls)
|
|
(err f ls))]
|
|
[(f a0 ls)
|
|
(if (and (procedure? f) (list? ls))
|
|
($apply f a0 ls)
|
|
(err f ls))]
|
|
[(f a0 a1 ls)
|
|
(if (and (procedure? f) (list? ls))
|
|
($apply f a0 a1 ls)
|
|
(err f ls))]
|
|
[(f a0 a1 . ls)
|
|
(fixandgo f a0 a1 ls ls ($cdr ls))]))
|
|
apply))
|
|
|
|
|
|
|
|
|
|
|
|
(primitive-set! 'assq
|
|
(letrec ([race
|
|
(lambda (x h t ls)
|
|
(if (pair? h)
|
|
(let ([a ($car h)] [h ($cdr h)])
|
|
(if (pair? a)
|
|
(if (eq? ($car a) x)
|
|
a
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(let ([a ($car h)])
|
|
(if (pair? a)
|
|
(if (eq? ($car a) x)
|
|
a
|
|
(race x ($cdr h) ($cdr t) ls))
|
|
(error 'assq "malformed alist ~s"
|
|
ls)))
|
|
(error 'assq "circular list ~s" ls))
|
|
(if (null? h)
|
|
#f
|
|
(error 'assq "~s is not a proper list" ls))))
|
|
(error 'assq "malformed alist ~s" ls)))
|
|
(if (null? h)
|
|
#f
|
|
(error 'assq "~s is not a proper list" ls))))])
|
|
(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)
|
|
(if (pair? h)
|
|
(let ([a ($car h)] [h ($cdr h)])
|
|
(if (pair? a)
|
|
(if (equal? ($car a) x)
|
|
a
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(let ([a ($car h)])
|
|
(if (pair? a)
|
|
(if (equal? ($car a) x)
|
|
a
|
|
(race x ($cdr h) ($cdr t) ls))
|
|
(error 'assoc "malformed alist ~s"
|
|
ls)))
|
|
(error 'assoc "circular list ~s" ls))
|
|
(if (null? h)
|
|
#f
|
|
(error 'assoc "~s is not a proper list" ls))))
|
|
(error 'assoc "malformed alist ~s" ls)))
|
|
(if (null? h)
|
|
#f
|
|
(error 'assoc "~s is not a proper list" ls))))])
|
|
(lambda (x ls)
|
|
(race x ls ls ls))))
|
|
|
|
|
|
(primitive-set! 'string->symbol
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(error 'string->symbol "~s is not a string" x))
|
|
(foreign-call "ik_intern_string" x)))
|
|
|
|
(primitive-set! 'oblist
|
|
(lambda ()
|
|
(foreign-call "ik_oblist")))
|
|
|
|
(primitive-set! 'gensym
|
|
(case-lambda
|
|
[() ($make-symbol #f)]
|
|
[(s)
|
|
(if (string? s)
|
|
($make-symbol s)
|
|
(if (symbol? s)
|
|
($make-symbol ($symbol-string s))
|
|
(error 'gensym "~s is neither a string nor a symbol" s)))]))
|
|
|
|
(primitive-set! 'putprop
|
|
(lambda (x k v)
|
|
(unless (symbol? x) (error 'putprop "~s is not a symbol" x))
|
|
(unless (symbol? k) (error 'putprop "~s is not a symbol" k))
|
|
(let ([p ($symbol-plist x)])
|
|
(cond
|
|
[(assq k p) => (lambda (x) (set-cdr! x v))]
|
|
[else
|
|
($set-symbol-plist! x (cons (cons k v) p))]))))
|
|
|
|
(primitive-set! 'getprop
|
|
(lambda (x k)
|
|
(unless (symbol? x) (error 'getprop "~s is not a symbol" x))
|
|
(unless (symbol? k) (error 'getprop "~s is not a symbol" k))
|
|
(let ([p ($symbol-plist x)])
|
|
(cond
|
|
[(assq k p) => cdr]
|
|
[else #f]))))
|
|
|
|
(primitive-set! 'remprop
|
|
(lambda (x k)
|
|
(unless (symbol? x) (error 'remprop "~s is not a symbol" x))
|
|
(unless (symbol? k) (error 'remprop "~s is not a symbol" k))
|
|
(let ([p ($symbol-plist x)])
|
|
(unless (null? p)
|
|
(let ([a ($car p)])
|
|
(cond
|
|
[(eq? ($car a) k) ($set-symbol-plist! x ($cdr p))]
|
|
[else
|
|
(let f ([q p] [p ($cdr p)])
|
|
(unless (null? p)
|
|
(let ([a ($car p)])
|
|
(cond
|
|
[(eq? ($car a) k)
|
|
($set-cdr! q ($cdr p))]
|
|
[else
|
|
(f p ($cdr p))]))))]))))))
|
|
|
|
(primitive-set! 'property-list
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'property-list "~s is not a symbol" x))
|
|
(letrec ([f
|
|
(lambda (ls ac)
|
|
(cond
|
|
[(null? ls) ac]
|
|
[else
|
|
(let ([a ($car ls)])
|
|
(f ($cdr ls)
|
|
(cons ($car a) (cons ($cdr a) ac))))]))])
|
|
(f ($symbol-plist x) '()))))
|
|
|
|
|
|
;;X (primitive-set! 'make-parameter
|
|
;;X (letrec ([make-param-no-guard
|
|
;;X (lambda (x)
|
|
;;X (lambda args
|
|
;;X (if (null? args)
|
|
;;X x
|
|
;;X (if (null? ($cdr args))
|
|
;;X (set! x ($car args))
|
|
;;X (error #f "too many arguments to parameter")))))]
|
|
;;X [make-param-with-guard
|
|
;;X (lambda (x g)
|
|
;;X (let ([f
|
|
;;X (lambda args
|
|
;;X (if (null? args)
|
|
;;X x
|
|
;;X (if (null? ($cdr args))
|
|
;;X (set! x (g ($car args)))
|
|
;;X (error #f "too many arguments to parameter"))))])
|
|
;;X (if (procedure? g)
|
|
;;X (begin (set! x (g x)) f)
|
|
;;X (error 'make-parameter "not a procedure ~s" g))))])
|
|
;;X (lambda args
|
|
;;X (if (pair? args)
|
|
;;X (let ([x ($car args)] [args ($cdr args)])
|
|
;;X (if (null? args)
|
|
;;X (make-param-no-guard x)
|
|
;;X (let ([g ($car args)])
|
|
;;X (if (null? ($cdr args))
|
|
;;X (make-param-with-guard x g)
|
|
;;X (error 'make-parameter "too many arguments")))))
|
|
;;X (error 'make-parameter "insufficient arguments")))))
|
|
;;X
|
|
|
|
(primitive-set! 'make-parameter
|
|
(case-lambda
|
|
[(x)
|
|
(case-lambda
|
|
[() x]
|
|
[(v) (set! x v)])]
|
|
[(x guard)
|
|
(unless (procedure? guard)
|
|
(error 'make-parameter "~s is not a procedure" guard))
|
|
(set! x (guard x))
|
|
(case-lambda
|
|
[() x]
|
|
[(v) (set! x (guard v))])]))
|
|
|
|
(let ()
|
|
(define vector-loop
|
|
(lambda (x y i n)
|
|
(or ($fx= i n)
|
|
(and (equal? ($vector-ref x i) ($vector-ref y i))
|
|
(vector-loop x y ($fxadd1 i) n)))))
|
|
(define string-loop
|
|
(lambda (x y i n)
|
|
(or ($fx= i n)
|
|
(and ($char= ($string-ref x i) ($string-ref y i))
|
|
(string-loop x y ($fxadd1 i) n)))))
|
|
(define equal?
|
|
(lambda (x y)
|
|
(cond
|
|
[(eq? x y) #t]
|
|
[(pair? x)
|
|
(and (pair? y)
|
|
(equal? ($car x) ($car y))
|
|
(equal? ($cdr x) ($cdr y)))]
|
|
[(vector? x)
|
|
(and (vector? y)
|
|
(let ([n ($vector-length x)])
|
|
(and ($fx= n ($vector-length y))
|
|
(vector-loop x y 0 n))))]
|
|
[(string? x)
|
|
(and (string? y)
|
|
(let ([n ($string-length x)])
|
|
(and ($fx= n ($string-length y))
|
|
(string-loop x y 0 n))))]
|
|
[(number? x) (and (number? y) (= x y))]
|
|
[else #f])))
|
|
(primitive-set! 'equal? equal?))
|
|
|
|
|
|
(let ()
|
|
(define who 'map)
|
|
(define len
|
|
(lambda (h t n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eq? h t)
|
|
(error who "circular list")
|
|
(len ($cdr h) ($cdr t) ($fx+ n 2)))
|
|
(if (null? h)
|
|
($fxadd1 n)
|
|
(error who "improper list"))))
|
|
(if (null? h)
|
|
n
|
|
(error who "improper list")))))
|
|
(define map1
|
|
(lambda (f a d n)
|
|
(cond
|
|
[(pair? d)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered!")
|
|
(cons (f a)
|
|
(map1 f ($car d) ($cdr d) ($fxsub1 n))))]
|
|
[(null? d)
|
|
(if ($fxzero? n)
|
|
(cons (f a) '())
|
|
(error who "list was altered"))]
|
|
[else (error who "list was altered")])))
|
|
(define map2
|
|
(lambda (f a1 a2 d1 d2 n)
|
|
(cond
|
|
[(pair? d1)
|
|
(cond
|
|
[(pair? d2)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered")
|
|
(cons (f a1 a2)
|
|
(map2 f
|
|
($car d1) ($car d2)
|
|
($cdr d1) ($cdr d2)
|
|
($fxsub1 n))))]
|
|
[else (error who "length mismatch")])]
|
|
[(null? d1)
|
|
(cond
|
|
[(null? d2)
|
|
(if ($fxzero? n)
|
|
(cons (f a1 a2) '())
|
|
(error who "list was altered"))]
|
|
[else (error who "length mismatch")])]
|
|
[else (error who "list was altered")])))
|
|
(define cars
|
|
(lambda (ls*)
|
|
(cond
|
|
[(null? ls*) '()]
|
|
[else
|
|
(let ([a (car ls*)])
|
|
(cond
|
|
[(pair? a)
|
|
(cons (car a) (cars (cdr ls*)))]
|
|
[else
|
|
(error 'map "length mismatch")]))])))
|
|
(define cdrs
|
|
(lambda (ls*)
|
|
(cond
|
|
[(null? ls*) '()]
|
|
[else
|
|
(let ([a (car ls*)])
|
|
(cond
|
|
[(pair? a)
|
|
(cons (cdr a) (cdrs (cdr ls*)))]
|
|
[else
|
|
(error 'map "length mismatch")]))])))
|
|
(define mapm
|
|
(lambda (f ls ls* n)
|
|
(cond
|
|
[(null? ls)
|
|
(if (andmap null? ls*)
|
|
(if (fxzero? n)
|
|
'()
|
|
(error 'map "lists were mutated during operation"))
|
|
(error 'map "length mismatch"))]
|
|
[(fxzero? n)
|
|
(error 'map "lists were mutated during operation")]
|
|
[else
|
|
(cons
|
|
(apply f (car ls) (cars ls*))
|
|
(mapm f (cdr ls) (cdrs ls*) (fxsub1 n)))])))
|
|
(primitive-set! 'map
|
|
(case-lambda
|
|
[(f ls)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(let ([d ($cdr ls)])
|
|
(map1 f ($car ls) d (len d d 0)))]
|
|
[(null? ls) '()]
|
|
[else (error who "improper list")])]
|
|
[(f ls ls2)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(if (pair? ls2)
|
|
(let ([d ($cdr ls)])
|
|
(map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
|
|
(error who "length mismatch"))]
|
|
[(null? ls)
|
|
(if (null? ls2)
|
|
'()
|
|
(error who "length mismatch"))]
|
|
[else (error who "not a list")])]
|
|
[(f ls . ls*)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(let ([n (len ls ls 0)])
|
|
(mapm f ls ls* n))]
|
|
[(null? ls)
|
|
(if (andmap null? ls*)
|
|
'()
|
|
(error who "length mismatch"))])])))
|
|
|
|
|
|
(let ()
|
|
(define who 'for-each)
|
|
(define len
|
|
(lambda (h t n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eq? h t)
|
|
(error who "circular list")
|
|
(len ($cdr h) ($cdr t) ($fx+ n 2)))
|
|
(if (null? h)
|
|
($fxadd1 n)
|
|
(error who "improper list"))))
|
|
(if (null? h)
|
|
n
|
|
(error who "improper list")))))
|
|
(define for-each1
|
|
(lambda (f a d n)
|
|
(cond
|
|
[(pair? d)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered!")
|
|
(begin
|
|
(f a)
|
|
(for-each1 f ($car d) ($cdr d) ($fxsub1 n))))]
|
|
[(null? d)
|
|
(if ($fxzero? n)
|
|
(f a)
|
|
(error who "list was altered"))]
|
|
[else (error who "list was altered")])))
|
|
(define for-each2
|
|
(lambda (f a1 a2 d1 d2 n)
|
|
(cond
|
|
[(pair? d1)
|
|
(cond
|
|
[(pair? d2)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered")
|
|
(begin
|
|
(f a1 a2)
|
|
(for-each2 f
|
|
($car d1) ($car d2)
|
|
($cdr d1) ($cdr d2)
|
|
($fxsub1 n))))]
|
|
[else (error who "length mismatch")])]
|
|
[(null? d1)
|
|
(cond
|
|
[(null? d2)
|
|
(if ($fxzero? n)
|
|
(f a1 a2)
|
|
(error who "list was altered"))]
|
|
[else (error who "length mismatch")])]
|
|
[else (error who "list was altered")])))
|
|
(primitive-set! 'for-each
|
|
(case-lambda
|
|
[(f ls)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(let ([d ($cdr ls)])
|
|
(for-each1 f ($car ls) d (len d d 0)))]
|
|
[(null? ls) (void)]
|
|
[else (error who "improper list")])]
|
|
[(f ls ls2)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(if (pair? ls2)
|
|
(let ([d ($cdr ls)])
|
|
(for-each2 f
|
|
($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
|
|
(error who "length mismatch"))]
|
|
[(null? ls)
|
|
(if (null? ls2)
|
|
(void)
|
|
(error who "length mismatch"))]
|
|
[else (error who "not a list")])]
|
|
[_ (error who "vararg not supported yet")])))
|
|
|
|
|
|
|
|
(let ()
|
|
(define who 'andmap)
|
|
(define len
|
|
(lambda (h t n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eq? h t)
|
|
(error who "circular list")
|
|
(len ($cdr h) ($cdr t) ($fx+ n 2)))
|
|
(if (null? h)
|
|
($fxadd1 n)
|
|
(error who "improper list"))))
|
|
(if (null? h)
|
|
n
|
|
(error who "improper list")))))
|
|
(define andmap1
|
|
(lambda (f a d n)
|
|
(cond
|
|
[(pair? d)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered!")
|
|
(and (f a)
|
|
(andmap1 f ($car d) ($cdr d) ($fxsub1 n))))]
|
|
[(null? d)
|
|
(if ($fxzero? n)
|
|
(f a)
|
|
(error who "list was altered"))]
|
|
[else (error who "list was altered")])))
|
|
(primitive-set! 'andmap
|
|
(case-lambda
|
|
[(f ls)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(let ([d ($cdr ls)])
|
|
(andmap1 f ($car ls) d (len d d 0)))]
|
|
[(null? ls) #t]
|
|
[else (error who "improper list")])]
|
|
[_ (error who "vararg not supported yet")])))
|
|
|
|
|
|
(let ()
|
|
(define who 'ormap)
|
|
(define len
|
|
(lambda (h t n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (eq? h t)
|
|
(error who "circular list")
|
|
(len ($cdr h) ($cdr t) ($fx+ n 2)))
|
|
(if (null? h)
|
|
($fxadd1 n)
|
|
(error who "improper list"))))
|
|
(if (null? h)
|
|
n
|
|
(error who "improper list")))))
|
|
(define ormap1
|
|
(lambda (f a d n)
|
|
(cond
|
|
[(pair? d)
|
|
(if ($fxzero? n)
|
|
(error who "list was altered!")
|
|
(or (f a)
|
|
(ormap1 f ($car d) ($cdr d) ($fxsub1 n))))]
|
|
[(null? d)
|
|
(if ($fxzero? n)
|
|
(f a)
|
|
(error who "list was altered"))]
|
|
[else (error who "list was altered")])))
|
|
(primitive-set! 'ormap
|
|
(case-lambda
|
|
[(f ls)
|
|
(unless (procedure? f)
|
|
(error who "~s is not a procedure" f))
|
|
(cond
|
|
[(pair? ls)
|
|
(let ([d ($cdr ls)])
|
|
(ormap1 f ($car ls) d (len d d 0)))]
|
|
[(null? ls) #f]
|
|
[else (error who "improper list")])]
|
|
[_ (error who "vararg not supported yet")])))
|
|
|
|
|
|
|
|
|
|
(let ()
|
|
(define reverse
|
|
(lambda (h t ls ac)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)] [a1 ($car h)])
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(let ([a2 ($car h)])
|
|
(reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac))))
|
|
(error 'append "circular list ~s" ls))
|
|
(if (null? h)
|
|
(cons a1 ac)
|
|
(error 'append "~s is not a proper list" ls))))
|
|
(if (null? h)
|
|
ac
|
|
(error 'append "~s is not a proper list" ls)))))
|
|
(define revcons
|
|
(lambda (ls ac)
|
|
(cond
|
|
[(null? ls) ac]
|
|
[else
|
|
(revcons ($cdr ls) (cons ($car ls) ac))])))
|
|
(define append
|
|
(lambda (ls ls*)
|
|
(cond
|
|
[(null? ls*) ls]
|
|
[else
|
|
(revcons (reverse ls ls ls '())
|
|
(append ($car ls*) ($cdr ls*)))])))
|
|
(primitive-set! 'append
|
|
(lambda (ls . ls*)
|
|
(append ls ls*))))
|
|
|
|
|
|
(primitive-set! 'list->vector
|
|
(letrec ([race
|
|
(lambda (h t ls n)
|
|
(if (pair? h)
|
|
(let ([h ($cdr h)])
|
|
(if (pair? h)
|
|
(if (not (eq? h t))
|
|
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
|
|
(error 'list->vector "circular list ~s" ls))
|
|
(if (null? h)
|
|
($fx+ n 1)
|
|
(error 'list->vector "~s is not a proper list" ls))))
|
|
(if (null? h)
|
|
n
|
|
(error 'list->vector "~s is not a proper list" ls))))]
|
|
[fill
|
|
(lambda (v i ls)
|
|
(cond
|
|
[(null? ls) v]
|
|
[else
|
|
(let ([c ($car ls)])
|
|
($vector-set! v i c)
|
|
(fill v ($fxadd1 i) (cdr ls)))]))])
|
|
(lambda (ls)
|
|
(let ([n (race ls ls ls 0)])
|
|
(let ([v (make-vector n)])
|
|
(fill v 0 ls))))))
|
|
|
|
|
|
(let ()
|
|
(define f
|
|
(lambda (v i ls)
|
|
(cond
|
|
[($fx< i 0) ls]
|
|
[else
|
|
(f v ($fxsub1 i) (cons ($vector-ref v i) ls))])))
|
|
(primitive-set! 'vector->list
|
|
(lambda (v)
|
|
(if (vector? v)
|
|
(let ([n ($vector-length v)])
|
|
(if ($fxzero? n)
|
|
'()
|
|
(f v ($fxsub1 n) '())))
|
|
(error 'vector->list "~s is not a vector" v)))))
|
|
|
|
(let ()
|
|
(define f
|
|
(lambda (n fill ls)
|
|
(cond
|
|
[($fxzero? n) ls]
|
|
[else
|
|
(f ($fxsub1 n) fill (cons fill ls))])))
|
|
(primitive-set! 'make-list
|
|
(case-lambda
|
|
[(n)
|
|
(if (and (fixnum? n) ($fx>= n 0))
|
|
(f n (void) '())
|
|
(error 'make-list "~s is not a valid length" n))]
|
|
[(n fill)
|
|
(if (and (fixnum? n) ($fx>= n 0))
|
|
(f n fill '())
|
|
(error 'make-list "~s is not a valid length" n))])))
|
|
|
|
(primitive-set! 'list (lambda x x))
|
|
|
|
(primitive-set! 'uuid
|
|
(lambda ()
|
|
(let ([s (make-string 16)])
|
|
(or (foreign-call "ik_uuid" s)
|
|
(error 'uuid "failed!")))))
|
|
|
|
(primitive-set! 'gensym->unique-string
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'gensym->unique-string "~s is not a gensym" x))
|
|
(let ([us ($symbol-unique-string x)])
|
|
(cond
|
|
[(string? us) us]
|
|
[(eq? us #t)
|
|
(error 'gensym->unique-string "~s is not a gensym" x)]
|
|
[else
|
|
(let ([id (uuid)])
|
|
($set-symbol-unique-string! x id)
|
|
id)]))))
|
|
|
|
(primitive-set! 'gensym-prefix
|
|
(make-parameter
|
|
"g"
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(error 'gensym-prefix "~s is not a string" x))
|
|
x)))
|
|
|
|
(primitive-set! 'gensym-count
|
|
(make-parameter
|
|
0
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) ($fx>= x 0))
|
|
(error 'gensym-count "~s is not a valid count" x))
|
|
x)))
|
|
|
|
(primitive-set! 'print-gensym
|
|
(make-parameter
|
|
#t
|
|
(lambda (x)
|
|
(unless (boolean? x)
|
|
(error 'print-gensym "~s is not a boolean" x))
|
|
x)))
|
|
|
|
;; X (primitive-set! 'make-hash-table
|
|
;; X (lambda ()
|
|
;; X (make-hash-table)))
|
|
;; X
|
|
;; X (primitive-set! 'hash-table?
|
|
;; X (lambda (x)
|
|
;; X (hash-table? x)))
|
|
;; X
|
|
;; X (primitive-set! 'get-hash-table
|
|
;; X (lambda (h k v)
|
|
;; X (foreign-call "ik_get_hash_table" h k v)))
|
|
;; X
|
|
;; X (primitive-set! 'put-hash-table!
|
|
;; X (lambda (h k v)
|
|
;; X (foreign-call "ik_put_hash_table" h k v)))
|
|
|
|
(primitive-set! 'bwp-object?
|
|
(lambda (x)
|
|
(bwp-object? x)))
|
|
|
|
(primitive-set! 'weak-cons
|
|
(lambda (a d)
|
|
(foreign-call "ikrt_weak_cons" a d)))
|
|
|
|
(primitive-set! 'weak-pair?
|
|
(lambda (x)
|
|
(and (pair? x)
|
|
(foreign-call "ikrt_is_weak_pair" x))))
|
|
|
|
(primitive-set! 'pointer-value
|
|
(lambda (x)
|
|
(pointer-value x)))
|
|
|
|
(primitive-set! 'date-string
|
|
(lambda ()
|
|
(let ([s (make-string 10)])
|
|
(foreign-call "ikrt_strftime" s "%F")
|
|
s)))
|
|
|
|
(primitive-set! 'features
|
|
(lambda ()
|
|
(append (macros) (public-primitives) '())))
|
|
|
|
(primitive-set! 'list*
|
|
(lambda (fst . rest)
|
|
(let f ([fst fst] [rest rest])
|
|
(cond
|
|
[(null? rest) fst]
|
|
[else
|
|
(cons fst (f ($car rest) ($cdr rest)))]))))
|
|
|
|
(primitive-set! 'command-line-arguments
|
|
(make-parameter ($arg-list)
|
|
(lambda (x)
|
|
(if (and (list? x) (andmap string? x))
|
|
x
|
|
(error 'command-list "invalid command-line-arguments ~s\n" x)))))
|
|
|