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 : fixnum-to-charlist ( fixnum -- charlist )
70 [char] 0 character-type nil cons
74 nil 2swap ( charlist fixnum )
79 2dup swap 10 mod swap ( charlist fixnum fixnummod )
80 2swap swap 10 / swap ( charlist fixnummod fixnumdiv )
81 -2rot ( fixnumdiv charlist fixnummod )
83 drop [char] 0 + character-type 2swap
84 cons ( fixnumdiv newcharlist )
92 :noname ( args -- string )
93 2dup 1 ensure-arg-count
94 car fixnum-type ensure-arg-type
98 fixnum-to-charlist ( fixnum charlist )
100 [char] - character-type 2swap cons
104 ; make-primitive number->string
106 :noname ( args -- symbol )
107 2dup 1 ensure-arg-count
108 car string-type ensure-arg-type
112 2dup car [char] - character-type objeq? if
116 2dup car [char] + character-type objeq? if
124 2dup nil objeq? false =
126 2dup car drop [char] 0 - -rot
127 2swap swap 10 * + -rot
136 ; make-primitive string->number
138 :noname ( args -- string )
139 2dup 1 ensure-arg-count
140 car symbol-type ensure-arg-type
145 ; make-primitive symbol->string
147 :noname ( args -- symbol )
148 2dup 1 ensure-arg-count
149 car string-type ensure-arg-type
154 ; make-primitive string->symbol
158 : add-prim ( args -- fixnum )
164 -rot cdr recurse drop
168 ' add-prim make-primitive +
170 :noname ( args -- fixnum )
187 :noname ( args -- fixnum )
193 -rot cdr recurse drop
198 :noname ( args -- fixnum )
199 2dup 2 ensure-arg-count
201 2dup car fixnum-type ensure-arg-type
202 2swap cdr car fixnum-type ensure-arg-type
207 ; make-primitive quotient
209 :noname ( args -- fixnum )
210 2dup 2 ensure-arg-count
212 2dup car fixnum-type ensure-arg-type
213 2swap cdr car fixnum-type ensure-arg-type
218 ; make-primitive remainder
222 : test-relation ( args -- bool )
226 true boolean-type exit
231 2dup car fixnum-type ensure-arg-type ( args arg0 )
232 2swap cdr ( arg0 args' )
236 true boolean-type exit
242 2dup nil objeq? false =
244 2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
245 2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
246 relcfa @ execute false = if
248 false boolean-type exit
251 2swap cdr ( arg0 args'' )
258 : fixnum-lt ( obj1 obj2 -- bool )
263 ['] fixnum-lt relcfa !
267 : fixnum-gt ( obj1 obj2 -- bool )
272 ['] fixnum-gt relcfa !
276 : fixnum-eq ( obj1 obj2 -- bool )
281 ['] fixnum-eq relcfa !
287 ( = Pairs and Lists = )
289 :noname ( args -- pair )
290 2dup 2 ensure-arg-count
292 2dup car 2swap cdr car
294 ; make-primitive cons
296 :noname ( args -- list )
297 \ args is already a list!
298 ; make-primitive list
300 :noname ( args -- pair )
301 2dup 1 ensure-arg-count
302 car pair-type ensure-arg-type
307 :noname ( args -- pair )
308 2dup 1 ensure-arg-count
309 car pair-type ensure-arg-type
314 :noname ( args -- pair )
315 2dup 2 ensure-arg-count
317 2swap car pair-type ensure-arg-type
322 ; make-primitive set-car!
324 :noname ( args -- pair )
325 2dup 2 ensure-arg-count
327 2swap car pair-type ensure-arg-type
332 ; make-primitive set-cdr!
334 ( = Polymorphic equality testing = )
336 :noname ( args -- bool )
337 2dup 2 ensure-arg-count