1 \ ==== Type predicates ==== {{{
3 :noname ( args -- boolobj )
4 nil objeq? boolean-type
5 ; 1 make-fa-primitive null?
7 :noname ( args -- boolobj )
8 boolean-type istype? -rot 2drop boolean-type
9 ; 1 make-fa-primitive boolean?
11 :noname ( args -- boolobj )
12 symbol-type istype? -rot 2drop boolean-type
13 ; 1 make-fa-primitive symbol?
15 :noname ( args -- boolobj )
16 fixnum-type istype? -rot 2drop boolean-type
17 ; 1 make-fa-primitive fixnum?
19 :noname ( args -- boolobj )
20 character-type istype? -rot 2drop boolean-type
21 ; 1 make-fa-primitive char?
23 :noname ( args -- boolobj )
24 string-type istype? -rot 2drop boolean-type
25 ; 1 make-fa-primitive string?
27 :noname ( args -- boolobj )
28 pair-type istype? -rot 2drop boolean-type
29 ; 1 make-fa-primitive pair?
31 :noname ( args -- boolobj )
32 primitive-proc-type istype? -rot 2drop boolean-type
33 ; 1 make-fa-primitive procedure?
37 \ ==== Type conversions ==== {{{
39 :noname ( args -- fixnum )
40 2dup 1 ensure-arg-count
41 car character-type ensure-arg-type
44 ; make-primitive char->integer
46 :noname ( args -- char )
47 2dup 1 ensure-arg-count
48 car fixnum-type ensure-arg-type
51 ; make-primitive integer->char
53 : fixnum-to-charlist ( fixnum -- charlist )
56 [char] 0 character-type nil cons
60 nil 2swap ( charlist fixnum )
65 2dup swap 10 mod swap ( charlist fixnum fixnummod )
66 2swap swap 10 / swap ( charlist fixnummod fixnumdiv )
67 -2rot ( fixnumdiv charlist fixnummod )
69 drop [char] 0 + character-type 2swap
70 cons ( fixnumdiv newcharlist )
78 :noname ( args -- string )
79 2dup 1 ensure-arg-count
80 car fixnum-type ensure-arg-type
84 fixnum-to-charlist ( fixnum charlist )
86 [char] - character-type 2swap cons
90 ; make-primitive number->string
92 :noname ( args -- symbol )
93 2dup 1 ensure-arg-count
94 car string-type ensure-arg-type
98 2dup car [char] - character-type objeq? if
102 2dup car [char] + character-type objeq? if
110 2dup nil objeq? false =
112 2dup car drop [char] 0 - -rot
113 2swap swap 10 * + -rot
122 ; make-primitive string->number
124 :noname ( args -- string )
125 2dup 1 ensure-arg-count
126 car symbol-type ensure-arg-type
131 ; make-primitive symbol->string
133 :noname ( args -- symbol )
134 2dup 1 ensure-arg-count
135 car string-type ensure-arg-type
140 ; make-primitive string->symbol
144 \ ==== Primitivle Arithmetic ==== {{{
148 :noname ( fixnum fixnum -- boolobj )
150 ; 2 make-fa-primitive fix:=
152 :noname ( fixnum fixnum -- boolobj )
153 drop swap drop < boolean-type
154 ; 2 make-fa-primitive fix:<
156 :noname ( fixnum fixnum -- boolobj )
157 drop swap drop > boolean-type
158 ; 2 make-fa-primitive fix:>
160 :noname ( fixnum fixnum -- boolobj )
161 drop swap drop <= boolean-type
162 ; 2 make-fa-primitive fix:<=
164 :noname ( fixnum fixnum -- boolobj )
165 drop swap drop >= boolean-type
166 ; 2 make-fa-primitive fix:>=
168 :noname ( fixnum fixnum -- boolobj )
170 ; 1 make-fa-primitive fix:zero?
172 :noname ( fixnum fixnum -- boolobj )
174 ; 1 make-fa-primitive fix:positive?
176 :noname ( fixnum fixnum -- boolobj )
178 ; 1 make-fa-primitive fix:negative?
180 :noname ( fixnum fixnum -- fixnum' )
181 drop swap drop + fixnum-type
182 ; 2 make-fa-primitive fix:+
184 :noname ( fixnum fixnum -- fixnum' )
185 drop swap drop - fixnum-type
186 ; 2 make-fa-primitive fix:-
188 :noname ( fixnum fixnum -- fixnum' )
189 drop swap drop * fixnum-type
190 ; 2 make-fa-primitive fix:*
192 :noname ( fixnum fixnum -- fixnum' )
193 drop swap drop / fixnum-type
194 ; 2 make-fa-primitive fix:quotient
196 :noname ( fixnum fixnum -- fixnum' )
197 drop swap drop mod fixnum-type
198 ; 2 make-fa-primitive fix:remainder
200 :noname ( fixnum -- fixnum+1 )
202 ; 1 make-fa-primitive fix:1+
204 :noname ( fixnum -- fixnum-1 )
206 ; 1 make-fa-primitive fix:-1+
208 :noname ( fixnum -- -fixnum )
210 ; 1 make-fa-primitive fix:neg
212 ( Find the GCD of n1 and n2 where n2 < n1. )
219 \ ==== Pairs and Lists ==== {{{
221 :noname ( arg1 arg2 -- pair )
223 ; 2 make-fa-primitive cons
225 :noname ( pair-obj -- obj )
227 ; pair-type 1 make-fa-type-primitive car
229 :noname ( args -- obj )
231 ; pair-type 1 make-fa-type-primitive cdr
233 :noname ( pair obj -- ok )
234 2swap pair-type ensure-arg-type
239 ; 2 make-fa-primitive set-car!
241 :noname ( pair obj -- ok )
242 2swap pair-type ensure-arg-type
247 ; 2 make-fa-primitive set-cdr!
251 \ ==== Polymorphic equality testing ==== {{{
253 :noname ( arg1 arg2 -- bool )
255 ; 2 make-fa-primitive eq?
259 \ ==== Input/Output ==== {{{
261 :noname ( args -- finalResult )
265 ; string-type 1 make-fa-type-primitive load
267 :noname ( args -- obj )
269 ; 0 make-fa-primitive read
273 :noname ( obj -- none )
275 ; 1 make-fa-primitive write
277 : displaypair ( pairobj -- )
281 nil? if 2drop exit then
282 pair-type istype? if space recurse exit then
286 : displaychar ( charobj -- )
289 : (displaystring) ( charlist -- )
298 : displaystring ( stringobj -- )
299 drop pair-type (displaystring)
303 pair-type istype? if ." (" displaypair ." )" exit then
304 character-type istype? if displaychar exit then
305 string-type istype? if displaystring exit then
310 :noname ( stringobj -- none )
312 ; string-type 1 make-fa-type-primitive display-string
314 :noname ( charobj -- none )
316 ; character-type 1 make-fa-type-primitive display-character
318 :noname ( obj -- none )
320 ; 1 make-fa-primitive display
322 :noname ( args -- none )
324 ; 0 make-fa-primitive newline
328 \ ==== Evaluation ==== {{{
330 :noname ( args -- result )
333 nil? false = if car then ( proc argvals )
336 ; make-primitive apply
340 \ ==== Miscellaneous ==== {{{
342 ( Produce a recoverable exception. )
343 :noname ( args -- result )
349 ." Error: " car display
354 recoverable-exception throw
355 ; make-primitive error
357 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
358 :noname ( args -- result )
359 [char] _ character-type nil cons
361 ; 0 make-fa-primitive gensym
363 ( Generate the NONE object indicating an unspecified return value. )
364 :noname ( args -- result )
366 ; 0 make-fa-primitive none