edf5894ab5e87962b15abc78991e5d260f775058
[scheme.forth.jl.git] / src / scheme-primitives.4th
1 \ ==== Type predicates ==== {{{
2
3 :noname ( args -- boolobj )
4     2dup 1 ensure-arg-count
5
6     car nil objeq? boolean-type
7 ; make-primitive null?
8
9 :noname ( args -- boolobj )
10     2dup 1 ensure-arg-count
11
12     car boolean-type istype? -rot 2drop boolean-type
13 ; make-primitive boolean?
14
15 :noname ( args -- boolobj )
16     2dup 1 ensure-arg-count
17
18     car symbol-type istype? -rot 2drop boolean-type
19 ; make-primitive symbol?
20
21 :noname ( args -- boolobj )
22     2dup 1 ensure-arg-count
23
24     car fixnum-type istype? -rot 2drop boolean-type
25 ; make-primitive integer?
26
27 :noname ( args -- boolobj )
28     2dup 1 ensure-arg-count
29
30     car character-type istype? -rot 2drop boolean-type
31 ; make-primitive char?
32
33 :noname ( args -- boolobj )
34     2dup 1 ensure-arg-count
35
36     car string-type istype? -rot 2drop boolean-type
37 ; make-primitive string?
38
39 :noname ( args -- boolobj )
40     2dup 1 ensure-arg-count
41
42     car pair-type istype? -rot 2drop boolean-type
43 ; make-primitive pair?
44
45 :noname ( args -- boolobj )
46     2dup 1 ensure-arg-count
47
48     car primitive-proc-type istype? -rot 2drop boolean-type
49 ; make-primitive procedure?
50
51 \ }}}
52
53 \ ==== Type conversions ==== {{{
54
55 :noname ( args -- fixnum )
56     2dup 1 ensure-arg-count
57     car character-type ensure-arg-type
58
59     drop fixnum-type
60 ; make-primitive char->integer
61
62 :noname ( args -- char )
63     2dup 1 ensure-arg-count
64     car fixnum-type ensure-arg-type
65
66     drop character-type
67 ; make-primitive integer->char
68
69 : fixnum-to-charlist ( fixnum -- charlist )
70     over 0= if
71         2drop
72         [char] 0 character-type nil cons
73         exit
74     then
75
76     nil 2swap ( charlist fixnum )
77
78     begin
79         over 0>
80     while
81         2dup swap 10 mod swap ( charlist fixnum fixnummod )
82         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
83         -2rot ( fixnumdiv charlist fixnummod )
84
85         drop [char] 0 + character-type 2swap
86         cons ( fixnumdiv newcharlist )
87
88         2swap 
89     repeat
90
91     2drop
92 ;
93
94 :noname ( args -- string )
95     2dup 1 ensure-arg-count
96     car fixnum-type ensure-arg-type
97
98     2dup swap abs swap
99
100     fixnum-to-charlist ( fixnum charlist )
101     2swap drop 0< if
102         [char] - character-type 2swap cons
103     then
104
105     drop string-type
106 ; make-primitive number->string
107
108 :noname ( args -- symbol )
109     2dup 1 ensure-arg-count
110     car string-type ensure-arg-type
111
112     drop pair-type
113
114     2dup car [char] - character-type objeq? if
115         cdr
116         true -rot
117     else
118         2dup car [char] + character-type objeq? if
119             cdr
120         then
121         false -rot
122     then
123
124     0 -rot
125     begin
126         2dup nil objeq? false =
127     while
128         2dup car drop [char] 0 - -rot
129         2swap swap 10 * + -rot
130         cdr
131     repeat
132
133     2drop
134
135     swap if -1 * then
136
137     fixnum-type
138 ; make-primitive string->number
139
140 :noname ( args -- string )
141     2dup 1 ensure-arg-count
142     car symbol-type ensure-arg-type
143
144     drop pair-type
145     duplicate-charlist
146     drop string-type
147 ; make-primitive symbol->string
148
149 :noname ( args -- symbol )
150     2dup 1 ensure-arg-count
151     car string-type ensure-arg-type
152
153     drop pair-type
154     duplicate-charlist
155     charlist>symbol
156 ; make-primitive string->symbol
157
158 \ }}}
159
160 \ ==== Arithmetic ==== {{{
161
162 : add-prim ( args -- fixnum )
163     2dup nil objeq? if
164         2drop
165         0 fixnum-type
166     else
167         2dup car drop
168         -rot cdr recurse drop
169         + fixnum-type
170     then
171 ;
172 ' add-prim make-primitive +
173
174 :noname ( args -- fixnum )
175     2dup nil objeq? if
176         2drop
177         0 fixnum-type
178     else
179         2dup car drop
180         -rot cdr
181         2dup nil objeq? if
182             2drop negate
183         else
184             add-prim drop
185             -
186         then
187         fixnum-type
188     then
189 ; make-primitive -
190
191 :noname ( args -- fixnum )
192     2dup nil objeq? if
193         2drop
194         1 fixnum-type
195     else
196         2dup car drop
197         -rot cdr recurse drop
198         * fixnum-type
199     then
200 ; make-primitive *
201
202 :noname ( args -- fixnum )
203     2dup 2 ensure-arg-count
204
205     2dup car fixnum-type ensure-arg-type
206     2swap cdr car fixnum-type ensure-arg-type
207
208     drop swap drop
209
210     / fixnum-type
211 ; make-primitive quotient
212
213 :noname ( args -- fixnum )
214     2dup 2 ensure-arg-count
215
216     2dup car fixnum-type ensure-arg-type
217     2swap cdr car fixnum-type ensure-arg-type
218
219     drop swap drop
220
221     mod fixnum-type
222 ; make-primitive remainder
223
224 variable relcfa
225
226 : test-relation ( args -- bool )
227
228     2dup nil objeq? if
229         2drop
230         true boolean-type exit
231     then
232
233     ( args )
234
235     2dup car fixnum-type ensure-arg-type ( args arg0 )
236     2swap cdr ( arg0 args' )
237
238     2dup nil objeq? if
239         2drop 2drop
240         true boolean-type exit
241     then
242
243     ( arg0 args' )
244
245     begin
246         2dup nil objeq? false =
247     while
248         2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
249         2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
250         relcfa @ execute false = if
251             2drop 2drop
252             false boolean-type exit
253         then
254
255         2swap cdr ( arg0 args'' )
256     repeat
257
258     2drop 2drop
259     true boolean-type
260
261
262 : fixnum-lt ( obj1 obj2 -- bool )
263     drop swap drop <
264 ;
265
266 :noname
267     ['] fixnum-lt relcfa !
268     test-relation
269 ; make-primitive <
270
271 : fixnum-gt ( obj1 obj2 -- bool )
272     drop swap drop >
273 ;
274
275 :noname
276     ['] fixnum-gt relcfa !
277     test-relation
278 ; make-primitive >
279
280 : fixnum-eq ( obj1 obj2 -- bool )
281     drop swap drop =
282 ;
283
284 :noname
285     ['] fixnum-eq relcfa !
286     test-relation
287 ; make-primitive =
288
289 hide relcfa
290
291 \ }}}
292
293 \ ==== Pairs and Lists ==== {{{
294
295 :noname ( args -- pair )
296     2dup 2 ensure-arg-count
297
298     2dup car 2swap cdr car
299     cons
300 ; make-primitive cons
301
302 :noname ( args -- list )
303     \ args is already a list!
304 ; make-primitive list
305
306 :noname ( args -- obj )
307     2dup 1 ensure-arg-count
308     car pair-type ensure-arg-type
309
310     car
311 ; make-primitive car
312
313 :noname ( args -- obj )
314     2dup 1 ensure-arg-count
315     car pair-type ensure-arg-type
316
317     cdr
318 ; make-primitive cdr
319
320 :noname ( args -- ok )
321     2dup 2 ensure-arg-count
322     2dup cdr car
323     2swap car pair-type ensure-arg-type
324
325     set-car!
326
327     ok-symbol
328 ; make-primitive set-car!
329
330 :noname ( args -- ok )
331     2dup 2 ensure-arg-count
332     2dup cdr car
333     2swap car pair-type ensure-arg-type
334
335     set-cdr!
336
337     ok-symbol
338 ; make-primitive set-cdr!
339
340 \ }}}
341
342 \ ==== Polymorphic equality testing ==== {{{
343
344 :noname ( args -- bool )
345     2dup 2 ensure-arg-count
346     2dup cdr car
347     2swap car
348
349     objeq? boolean-type
350 ; make-primitive eq?
351
352 \ }}}
353
354 \ ==== Input/Output ==== {{{
355
356 :noname ( args -- finalResult )
357     2dup 1 ensure-arg-count
358     car string-type ensure-arg-type
359
360     drop pair-type
361     pad charlist>cstr
362     pad swap load
363 ; make-primitive load
364
365 :noname ( args -- obj )
366     0 ensure-arg-count
367     read
368 ; make-primitive read
369
370 defer display
371 :noname ( args -- none )
372     2dup 1 ensure-arg-count
373
374     car print
375
376     none
377 ; make-primitive write
378
379 : displaypair ( pairobj -- )
380     2dup
381     car display
382     cdr
383     nil? if 2drop exit then
384     pair-type istype? if space recurse exit then
385     ."  . " display
386 ;
387
388 : displaychar ( charobj -- )
389     drop emit ;
390
391 : (displaystring) ( charlist -- )
392     nil? if
393         2drop
394     else
395         2dup car displaychar
396         cdr recurse
397     then
398 ;
399
400 : displaystring ( stringobj -- )
401     drop pair-type (displaystring)
402 ;
403
404 :noname ( obj -- )
405     pair-type istype? if ." (" displaypair ." )" exit then
406     character-type istype? if displaychar exit then
407     string-type istype? if displaystring exit then
408     
409     print
410 ; is display
411
412 :noname ( args -- none )
413     2dup 1 ensure-arg-count
414     car string-type ensure-arg-type
415
416     displaystring
417
418     none
419 ; make-primitive display-string
420
421 :noname ( args -- none )
422     2dup 1 ensure-arg-count
423     car character-type ensure-arg-type
424
425     displaychar
426
427     none
428 ; make-primitive display-character
429
430 :noname ( args -- none )
431     2dup 1 ensure-arg-count
432     car
433
434     display
435
436     none
437 ; make-primitive display
438
439 :noname ( args -- none )
440     0 ensure-arg-count
441
442     cr
443
444     none
445 ; make-primitive newline
446
447 \ }}}
448
449 \ ==== Evaluation ==== {{{
450
451 :noname ( args -- result )
452     2dup car 2swap cdr
453
454     nil? false = if car then ( proc argvals )
455     
456     apply
457 ; make-primitive apply 
458
459 \ }}}
460
461 \ ==== Miscellaneous  ==== {{{
462
463 ( Produce a recoverable exception. )
464 :noname ( args -- result )
465     bold fg red
466
467     nil? if
468         ." Error."
469     else
470         ." Error: " car display
471     then
472
473     reset-term
474
475     recoverable-exception throw
476 ; make-primitive error
477
478 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
479 :noname ( args -- result )
480     0 ensure-arg-count
481
482     [char] _  character-type nil cons
483     drop symbol-type
484 ; make-primitive gensym
485
486 ( Generate the NONE object indicating an unspecified return value. )
487 :noname ( args -- result )
488     0 ensure-arg-count
489     
490     none
491 ; make-primitive none
492
493 \ }}}
494
495 \ vim:fdm=marker