Improved let macro hygiene.
[scheme.forth.jl.git] / src / scheme-primitives.4th
1 \ ==== Type predilcates ==== {{{
2
3 :noname ( args -- boolobj )
4     nil objeq? boolean-type
5 ; 1 make-fa-primitive null?
6
7 :noname ( args -- boolobj )
8     boolean-type istype? -rot 2drop boolean-type
9 ; 1 make-fa-primitive boolean?
10
11 :noname ( args -- boolobj )
12     symbol-type istype? -rot 2drop boolean-type
13 ; 1 make-fa-primitive symbol?
14
15 :noname ( args -- boolobj )
16     fixnum-type istype? -rot 2drop boolean-type
17 ; 1 make-fa-primitive fixnum?
18
19 :noname ( args -- boolobj )
20     flonum-type istype? -rot 2drop boolean-type
21 ; 1 make-fa-primitive flonum?
22
23 :noname ( args -- boolobj )
24     ratnum-type istype? -rot 2drop boolean-type
25 ; 1 make-fa-primitive ratnum?
26
27 :noname ( args -- boolobj )
28     character-type istype? -rot 2drop boolean-type
29 ; 1 make-fa-primitive char?
30
31 :noname ( args -- boolobj )
32     string-type istype? -rot 2drop boolean-type
33 ; 1 make-fa-primitive string?
34
35 :noname ( args -- boolobj )
36     pair-type istype? -rot 2drop boolean-type
37 ; 1 make-fa-primitive pair?
38
39 :noname ( args -- boolobj )
40     primitive-proc-type istype? if
41         true
42     else
43         compound-proc-type istype?
44     then
45         
46     -rot 2drop boolean-type
47 ; 1 make-fa-primitive procedure?
48
49 :noname ( args -- boolobj )
50     port-type istype? -rot 2drop boolean-type
51 ; 1 make-fa-primitive port?
52
53 \ }}}
54
55 \ ==== Type conversions ==== {{{
56
57 :noname ( args -- fixnum )
58     2dup 1 ensure-arg-count
59     car character-type ensure-arg-type
60
61     drop fixnum-type
62 ; make-primitive char->integer
63
64 :noname ( args -- char )
65     2dup 1 ensure-arg-count
66     car fixnum-type ensure-arg-type
67
68     drop character-type
69 ; make-primitive integer->char
70
71 : fixnum-to-charlist ( fixnum -- charlist )
72     over 0= if
73         2drop
74         [char] 0 character-type nil cons
75         exit
76     then
77
78     nil 2swap ( charlist fixnum )
79
80     begin
81         over 0>
82     while
83         2dup swap 10 mod swap ( charlist fixnum fixnummod )
84         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
85         -2rot ( fixnumdiv charlist fixnummod )
86
87         drop [char] 0 + character-type 2swap
88         cons ( fixnumdiv newcharlist )
89
90         2swap 
91     repeat
92
93     2drop
94 ;
95
96 :noname ( args -- string )
97     2dup 1 ensure-arg-count
98     car fixnum-type ensure-arg-type
99
100     2dup swap abs swap
101
102     fixnum-to-charlist ( fixnum charlist )
103     2swap drop 0< if
104         [char] - character-type 2swap cons
105     then
106
107     drop string-type
108 ; make-primitive number->string
109
110 :noname ( args -- symbol )
111     2dup 1 ensure-arg-count
112     car string-type ensure-arg-type
113
114     drop pair-type
115
116     2dup car [char] - character-type objeq? if
117         cdr
118         true -rot
119     else
120         2dup car [char] + character-type objeq? if
121             cdr
122         then
123         false -rot
124     then
125
126     0 -rot
127     begin
128         2dup nil objeq? false =
129     while
130         2dup car drop [char] 0 - -rot
131         2swap swap 10 * + -rot
132         cdr
133     repeat
134
135     2drop
136
137     swap if -1 * then
138
139     fixnum-type
140 ; make-primitive string->number
141
142 :noname ( args -- string )
143     2dup 1 ensure-arg-count
144     car symbol-type ensure-arg-type
145
146     drop pair-type
147     duplicate-charlist
148     drop string-type
149 ; make-primitive symbol->string
150
151 :noname ( args -- symbol )
152     2dup 1 ensure-arg-count
153     car string-type ensure-arg-type
154
155     drop pair-type
156     duplicate-charlist
157     charlist>symbol
158 ; make-primitive string->symbol
159
160 :noname ( charlist -- string )
161     2dup 1 ensure-arg-count
162
163     car nil? if
164         2drop
165         nil nil cons
166         drop string-type
167         exit
168     then
169     
170     pair-type ensure-arg-type
171
172     duplicate-charlist
173     drop string-type
174 ; make-primitive list->string
175
176 :noname ( string -- charlist )
177     2dup 1 ensure-arg-count
178     car string-type ensure-arg-type
179
180     drop pair-type
181
182     2dup car nil? if
183         2swap 2drop
184     else
185         2drop
186         duplicate-charlist
187     then
188
189 ; make-primitive string->list
190
191 \ }}}
192
193 \ ==== Numeric types ==== {{{
194
195 \ --- Fixnums ---
196
197 :noname ( fixnum fixnum -- boolobj )
198     objeq? boolean-type
199 ; 2 make-fa-primitive fix:=
200
201 :noname ( fixnum fixnum -- boolobj )
202     drop swap drop < boolean-type
203 ; 2 make-fa-primitive fix:<
204
205 :noname ( fixnum fixnum -- boolobj )
206     drop swap drop > boolean-type
207 ; 2 make-fa-primitive fix:>
208
209 :noname ( fixnum fixnum -- boolobj )
210     drop swap drop <= boolean-type
211 ; 2 make-fa-primitive fix:<=
212
213 :noname ( fixnum fixnum -- boolobj )
214     drop swap drop >= boolean-type
215 ; 2 make-fa-primitive fix:>=
216
217 :noname ( fixnum -- boolobj )
218     drop 0= boolean-type
219 ; 1 make-fa-primitive fix:zero?
220
221 :noname ( fixnum -- boolobj )
222     drop 0> boolean-type
223 ; 1 make-fa-primitive fix:positive?
224
225 :noname ( fixnum -- boolobj )
226     drop 0< boolean-type
227 ; 1 make-fa-primitive fix:negative?
228
229 :noname ( fixnum fixnum -- fixnum' )
230     drop swap drop + fixnum-type
231 ; 2 make-fa-primitive fix:+
232
233 :noname ( fixnum fixnum -- fixnum' )
234     drop swap drop - fixnum-type
235 ; 2 make-fa-primitive fix:-
236
237 :noname ( fixnum fixnum -- fixnum' )
238     drop swap drop * fixnum-type
239 ; 2 make-fa-primitive fix:*
240
241 :noname ( fixnum fixnum -- fixnum' )
242     drop swap drop / fixnum-type
243 ; 2 make-fa-primitive fix:quotient
244
245 :noname ( fixnum fixnum -- fixnum' )
246     drop swap drop mod fixnum-type
247 ; 2 make-fa-primitive fix:remainder
248
249 :noname ( fixnum -- fixnum+1 )
250     swap 1+ swap
251 ; 1 make-fa-primitive fix:1+
252
253 :noname ( fixnum -- fixnum-1 )
254     swap 1- swap
255 ; 1 make-fa-primitive fix:-1+
256
257 :noname ( fixnum -- -fixnum )
258     swap negate swap
259 ; 1 make-fa-primitive fix:neg
260
261 :noname ( fixnum -- -fixnum )
262     swap abs swap
263 ; 1 make-fa-primitive fix:abs
264
265 :noname ( fixnum fixnum -- fixnum' )
266     drop swap drop gcd fixnum-type
267 ; 2 make-fa-primitive fix:gcd
268
269 \ --- Flonums ---
270
271 :noname ( flonum flonum -- bool )
272     objeq? boolean-type
273 ; 2 make-fa-primitive flo:=
274
275 :noname ( flonum flonum -- bool )
276     drop swap drop f< boolean-type
277 ; 2 make-fa-primitive flo:<
278
279 :noname ( flonum flonum -- bool )
280     drop swap drop f> boolean-type
281 ; 2 make-fa-primitive flo:>
282
283
284 :noname ( flonum -- bool )
285     drop 0.0 = boolean-type
286 ; 1 make-fa-primitive flo:zero?
287
288 :noname ( flonum -- bool )
289     drop 0.0 f> boolean-type
290 ; 1 make-fa-primitive flo:positive?
291
292 :noname ( flonum -- bool )
293     drop 0.0 f< boolean-type
294 ; 1 make-fa-primitive flo:negative?
295
296
297 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
298     drop swap drop f+ flonum-type
299 ; 2 make-fa-primitive flo:+
300
301 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
302     drop swap drop f- flonum-type
303 ; 2 make-fa-primitive flo:-
304
305 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
306     drop swap drop f* flonum-type
307 ; 2 make-fa-primitive flo:*
308
309 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
310     drop swap drop f/ flonum-type
311 ; 2 make-fa-primitive flo:/
312
313 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
314     drop swap drop f/ flonum-type
315 ; 2 make-fa-primitive flo:/
316
317
318 :noname ( flonum -- bool )
319     drop dup
320     fnan? swap finf? or invert
321 ; 1 make-fa-primitive flo:finite?
322
323
324 :noname ( flonum -- flonum )
325     swap -1.0 f* swap
326 ; 1 make-fa-primitive flo:neg
327
328 :noname ( flonum -- flonum )
329     swap fabs swap
330 ; 1 make-fa-primitive flo:abs
331
332 :noname ( flonum -- flonum )
333     swap fexp swap
334 ; 1 make-fa-primitive flo:exp
335
336 :noname ( flonum -- flonum )
337     swap flog swap
338 ; 1 make-fa-primitive flo:log
339
340 :noname ( flonum -- flonum )
341     swap fsin swap
342 ; 1 make-fa-primitive flo:sin
343
344 :noname ( flonum -- flonum )
345     swap fcos swap
346 ; 1 make-fa-primitive flo:cos
347
348 :noname ( flonum -- flonum )
349     swap ftan swap
350 ; 1 make-fa-primitive flo:tan
351
352 :noname ( flonum -- flonum )
353     swap fasin swap
354 ; 1 make-fa-primitive flo:asin
355
356 :noname ( flonum -- flonum )
357     swap facos swap
358 ; 1 make-fa-primitive flo:acos
359
360 :noname ( flonum -- flonum )
361     swap fatan swap
362 ; 1 make-fa-primitive flo:atan
363
364 :noname ( flonum -- flonum )
365     swap fsqrt swap
366 ; 1 make-fa-primitive flo:sqrt
367
368 :noname ( flonum flonum -- flonum )
369     drop swap drop f^ flonum-type
370 ; 2 make-fa-primitive flo:expt
371
372 :noname ( flonum -- flonum )
373     swap floor swap
374 ; 1 make-fa-primitive flo:floor
375
376 :noname ( flonum -- flonum )
377     swap ceiling swap
378 ; 1 make-fa-primitive flo:ceiling
379
380 :noname ( flonum -- flonum )
381     swap truncate swap
382 ; 1 make-fa-primitive flo:truncate
383
384 :noname ( flonum -- flonum )
385     swap fround swap
386 ; 1 make-fa-primitive flo:round
387
388 :noname ( flonum -- flonum )
389     drop floor f->i fixnum-type
390 ; 1 make-fa-primitive flo:floor->exact
391
392 :noname ( flonum -- flonum )
393     drop ceiling f->i fixnum-type
394 ; 1 make-fa-primitive flo:ceiling->exact
395
396 :noname ( flonum -- flonum )
397     drop truncate f->i fixnum-type
398 ; 1 make-fa-primitive flo:truncate->exact
399
400 :noname ( flonum -- flonum )
401     drop f->i fixnum-type
402 ; 1 make-fa-primitive flo:round->exact
403
404 :noname ( flonum flonum -- flonum )
405     drop swap drop f/ fatan flonum-type
406 ; 2 make-fa-primitive flo:atan2
407
408 \ --- Rationals ---
409
410 ' make-rational 2 make-fa-primitive make-rational
411
412 :noname ( ratnum -- fixnum )
413     drop pair-type car
414 ; 1 make-fa-primitive rat:numerator
415
416 :noname ( ratnum -- fixnum )
417     drop pair-type cdr
418 ; 1 make-fa-primitive rat:denominator
419
420 \ --- Conversion ---
421
422 :noname ( fixnum -- flonum )
423     drop i->f flonum-type
424 ; 1 make-fa-primitive fixnum->flonum
425
426 \ }}}
427
428 \ ==== Pairs and Lists ==== {{{
429
430 :noname ( arg1 arg2 -- pair )
431     cons
432 ; 2 make-fa-primitive cons
433
434 :noname ( pair-obj -- obj )
435     car
436 ; pair-type 1 make-fa-type-primitive car
437
438 :noname ( args -- obj )
439     cdr
440 ; pair-type 1 make-fa-type-primitive cdr
441
442 :noname ( pair obj  -- ok )
443     2swap pair-type ensure-arg-type
444
445     set-car!
446
447     ok-symbol
448 ; 2 make-fa-primitive set-car!
449
450 :noname ( pair obj -- ok )
451     2swap pair-type ensure-arg-type
452
453     set-cdr!
454
455     ok-symbol
456 ; 2 make-fa-primitive set-cdr!
457
458 \ }}}
459
460 \ ==== Polymorphic equality testing ==== {{{
461
462 :noname ( arg1 arg2 -- bool )
463     objeq? boolean-type
464 ; 2 make-fa-primitive eq?
465
466 \ }}}
467
468 \ ==== Input/Output ==== {{{
469
470 :noname ( -- port )
471     console-i/o-port obj@
472 ; 0 make-fa-primitive console-i/o-port
473
474 :noname ( -- port )
475     current-input-port obj@
476 ; 0 make-fa-primitive current-input-port
477
478 :noname ( args -- charobj )
479     nil? if
480         2drop current-input-port obj@
481     else
482         car port-type ensure-arg-type
483     then
484
485     read-char
486 ; make-primitive read-char
487
488 :noname ( args -- charobj )
489     nil? if
490         2drop current-input-port obj@
491     else
492         car port-type ensure-arg-type
493     then
494
495     peek-char
496 ; make-primitive peek-char
497
498 :noname ( args -- stringobj )
499     nil? if
500         2drop current-input-port obj@
501     else
502         car port-type ensure-arg-type
503     then
504
505     read-line
506 ; make-primitive read-line
507
508 : charlist>cstr ( charlist addr -- n )
509
510     dup 2swap ( origaddr addr charlist )
511
512     begin 
513         nil? false =
514     while
515         2dup cdr 2swap car 
516         drop ( origaddr addr charlist char )
517         -rot 2swap ( origaddr charlist addr char )
518         over !
519         1+ -rot ( origaddr nextaddr charlist )
520     repeat
521
522     2drop ( origaddr finaladdr ) 
523     swap -
524 ;
525
526 :noname ( args -- finalResult )
527     drop pair-type
528     pad charlist>cstr
529     pad swap load
530 ; string-type 1 make-fa-type-primitive load
531
532 :noname ( args -- obj )
533     read
534 ; 0 make-fa-primitive read
535
536 defer display
537
538 :noname ( obj -- none )
539     print none
540 ; 1 make-fa-primitive write
541
542 : displaypair ( pairobj -- )
543     2dup
544     car display
545     cdr
546     nil? if 2drop exit then
547     pair-type istype? if space recurse exit then
548     ."  . " display
549 ;
550
551 : displaychar ( charobj -- )
552     drop emit ;
553
554 : (displaystring) ( charlist -- )
555     nil? if
556         2drop
557     else
558         2dup car displaychar
559         cdr recurse
560     then
561 ;
562
563 : displaystring ( stringobj -- )
564     drop pair-type (displaystring)
565 ;
566
567 :noname ( obj -- )
568     pair-type istype? if ." (" displaypair ." )" exit then
569     character-type istype? if displaychar exit then
570     string-type istype? if displaystring exit then
571     
572     print
573 ; is display
574
575 :noname ( stringobj -- none )
576     displaystring none
577 ; string-type 1 make-fa-type-primitive display-string
578
579 :noname ( charobj -- none )
580     displaychar none
581 ; character-type 1 make-fa-type-primitive display-character
582
583 :noname ( obj -- none )
584     display none
585 ; 1 make-fa-primitive display
586
587 :noname ( args -- none )
588     cr none
589 ; 0 make-fa-primitive newline
590
591 \ }}}
592
593 \ ==== Evaluation ==== {{{
594
595 :noname ( args -- result )
596     2dup car 2swap cdr
597
598     nil? false = if car then ( proc argvals )
599     
600     apply
601 ; make-primitive apply 
602
603 \ }}}
604
605 \ ==== Miscellaneous  ==== {{{
606
607 ( Produce a recoverable exception. )
608 :noname ( args -- result )
609     bold fg red
610
611     nil? if
612         ." Error."
613     else
614         ." Error: " car display
615     then
616
617     reset-term
618
619     recoverable-exception throw
620 ; make-primitive error
621
622 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
623 :noname ( args -- result )
624     [char] _  character-type nil cons
625     drop symbol-type
626 ; 0 make-fa-primitive gensym
627
628 ( Generate the NONE object indicating an unspecified return value. )
629 :noname ( args -- result )
630     none
631 ; 0 make-fa-primitive none
632
633 \ }}}
634
635 \ vim:fdm=marker