1 ( = Type predicates = )
3 :noname ( args -- boolobj )
4 2dup 1 ensure-arg-count
6 car nil objeq? boolean-type
9 :noname ( args -- boolobj )
10 2dup 1 ensure-arg-count
12 car boolean-type istype? -rot 2drop boolean-type
13 ; make-primitive boolean?
15 :noname ( args -- boolobj )
16 2dup 1 ensure-arg-count
18 car symbol-type istype? -rot 2drop boolean-type
19 ; make-primitive symbol?
21 :noname ( args -- boolobj )
22 2dup 1 ensure-arg-count
24 car fixnum-type istype? -rot 2drop boolean-type
25 ; make-primitive integer?
27 :noname ( args -- boolobj )
28 2dup 1 ensure-arg-count
30 car character-type istype? -rot 2drop boolean-type
31 ; make-primitive char?
33 :noname ( args -- boolobj )
34 2dup 1 ensure-arg-count
36 car string-type istype? -rot 2drop boolean-type
37 ; make-primitive string?
39 :noname ( args -- boolobj )
40 2dup 1 ensure-arg-count
42 car pair-type istype? -rot 2drop boolean-type
43 ; make-primitive pair?
45 :noname ( args -- boolobj )
46 2dup 1 ensure-arg-count
48 car primitive-proc-type istype? -rot 2drop boolean-type
49 ; make-primitive procedure?
51 ( = Type conversions = )
53 :noname ( args -- fixnum )
54 2dup 1 ensure-arg-count
55 car character-type ensure-arg-type
58 ; make-primitive char->integer
60 :noname ( args -- char )
61 2dup 1 ensure-arg-count
62 car fixnum-type ensure-arg-type
65 ; make-primitive integer->char
67 : num-to-charlist ( num -- charlist )
69 [char] 0 character-type nil cons
78 dup 10 mod swap 10 / swap
80 [char] 0 + character-type 2swap
86 :noname ( args -- string )
87 2dup 1 ensure-arg-count
88 car fixnum-type ensure-arg-type
92 dup 0< swap abs ( bool num )
95 [char] - character-type 2swap cons
99 ; make-primitive number->string
101 :noname ( args -- symbol )
102 2dup 1 ensure-arg-count
103 car string-type ensure-arg-type
107 2dup car [char] - character-type objeq? if
111 2dup car [char] + character-type objeq? if
119 2dup nil objeq? false =
121 2dup car drop [char] 0 - -rot
122 2swap swap 10 * + -rot
131 ; make-primitive string->number
133 :noname ( args -- string )
134 2dup 1 ensure-arg-count
135 car symbol-type ensure-arg-type
140 ; make-primitive symbol->string
142 :noname ( args -- symbol )
143 2dup 1 ensure-arg-count
144 car string-type ensure-arg-type
149 ; make-primitive string->symbol
153 : add-prim ( args -- fixnum )
159 -rot cdr recurse drop
163 ' add-prim make-primitive +
165 :noname ( args -- fixnum )
182 :noname ( args -- fixnum )
188 -rot cdr recurse drop
193 :noname ( args -- fixnum )
194 2dup 2 ensure-arg-count
196 2dup car fixnum-type ensure-arg-type
197 2swap cdr car fixnum-type ensure-arg-type
202 ; make-primitive quotient
204 :noname ( args -- fixnum )
205 2dup 2 ensure-arg-count
207 2dup car fixnum-type ensure-arg-type
208 2swap cdr car fixnum-type ensure-arg-type
213 ; make-primitive remainder
217 : test-relation ( args -- bool )
221 true boolean-type exit
226 2dup car fixnum-type ensure-arg-type ( args arg0 )
227 2swap cdr ( arg0 args' )
231 true boolean-type exit
237 2dup nil objeq? false =
239 2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
240 2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
241 relcfa @ execute false = if
243 false boolean-type exit
246 2swap cdr ( arg0 args'' )
253 : fixnum-lt ( obj1 obj2 -- bool )
258 ['] fixnum-lt relcfa !
262 : fixnum-gt ( obj1 obj2 -- bool )
267 ['] fixnum-gt relcfa !
271 : fixnum-eq ( obj1 obj2 -- bool )
276 ['] fixnum-eq relcfa !
282 ( = Pairs and Lists = )
284 :noname ( args -- pair )
285 2dup 2 ensure-arg-count
287 2dup car 2swap cdr car
289 ; make-primitive cons
291 :noname ( args -- list )
292 \ args is already a list!
293 ; make-primitive list
295 :noname ( args -- pair )
296 2dup 1 ensure-arg-count
297 car pair-type ensure-arg-type
302 :noname ( args -- pair )
303 2dup 1 ensure-arg-count
304 car pair-type ensure-arg-type
309 :noname ( args -- pair )
310 2dup 2 ensure-arg-count
312 2swap car pair-type ensure-arg-type
317 ; make-primitive set-car!
319 :noname ( args -- pair )
320 2dup 2 ensure-arg-count
322 2swap car pair-type ensure-arg-type
327 ; make-primitive set-cdr!
329 ( = Polymorphic equality testing = )
331 :noname ( args -- bool )
332 2dup 2 ensure-arg-count