Updated links in readme.
[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 :noname ( flonum flonum -- bool )
284     drop swap drop f<= boolean-type
285 ; 2 make-fa-primitive flo:<=
286
287 :noname ( flonum flonum -- bool )
288     drop swap drop f>= boolean-type
289 ; 2 make-fa-primitive flo:>=
290
291 :noname ( flonum -- bool )
292     drop 0.0 = boolean-type
293 ; 1 make-fa-primitive flo:zero?
294
295 :noname ( flonum -- bool )
296     drop 0.0 f> boolean-type
297 ; 1 make-fa-primitive flo:positive?
298
299 :noname ( flonum -- bool )
300     drop 0.0 f< boolean-type
301 ; 1 make-fa-primitive flo:negative?
302
303
304 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
305     drop swap drop f+ flonum-type
306 ; 2 make-fa-primitive flo:+
307
308 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
309     drop swap drop f- flonum-type
310 ; 2 make-fa-primitive flo:-
311
312 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
313     drop swap drop f* flonum-type
314 ; 2 make-fa-primitive flo:*
315
316 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
317     drop swap drop f/ flonum-type
318 ; 2 make-fa-primitive flo:/
319
320 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
321     drop swap drop f/ flonum-type
322 ; 2 make-fa-primitive flo:/
323
324
325 :noname ( flonum -- bool )
326     drop dup
327     fnan? swap finf? or invert
328 ; 1 make-fa-primitive flo:finite?
329
330
331 :noname ( flonum -- flonum )
332     swap -1.0 f* swap
333 ; 1 make-fa-primitive flo:neg
334
335 :noname ( flonum -- flonum )
336     swap fabs swap
337 ; 1 make-fa-primitive flo:abs
338
339 :noname ( flonum -- flonum )
340     swap fexp swap
341 ; 1 make-fa-primitive flo:exp
342
343 :noname ( flonum -- flonum )
344     swap flog swap
345 ; 1 make-fa-primitive flo:log
346
347 :noname ( flonum -- flonum )
348     swap fsin swap
349 ; 1 make-fa-primitive flo:sin
350
351 :noname ( flonum -- flonum )
352     swap fcos swap
353 ; 1 make-fa-primitive flo:cos
354
355 :noname ( flonum -- flonum )
356     swap ftan swap
357 ; 1 make-fa-primitive flo:tan
358
359 :noname ( flonum -- flonum )
360     swap fasin swap
361 ; 1 make-fa-primitive flo:asin
362
363 :noname ( flonum -- flonum )
364     swap facos swap
365 ; 1 make-fa-primitive flo:acos
366
367 :noname ( flonum -- flonum )
368     swap fatan swap
369 ; 1 make-fa-primitive flo:atan
370
371 :noname ( flonum -- flonum )
372     swap fsqrt swap
373 ; 1 make-fa-primitive flo:sqrt
374
375 :noname ( flonum flonum -- flonum )
376     drop swap drop f^ flonum-type
377 ; 2 make-fa-primitive flo:expt
378
379 :noname ( flonum -- flonum )
380     swap floor swap
381 ; 1 make-fa-primitive flo:floor
382
383 :noname ( flonum -- flonum )
384     swap ceiling swap
385 ; 1 make-fa-primitive flo:ceiling
386
387 :noname ( flonum -- flonum )
388     swap truncate swap
389 ; 1 make-fa-primitive flo:truncate
390
391 :noname ( flonum -- flonum )
392     swap fround swap
393 ; 1 make-fa-primitive flo:round
394
395 :noname ( flonum -- flonum )
396     drop floor f->i fixnum-type
397 ; 1 make-fa-primitive flo:floor->exact
398
399 :noname ( flonum -- flonum )
400     drop ceiling f->i fixnum-type
401 ; 1 make-fa-primitive flo:ceiling->exact
402
403 :noname ( flonum -- flonum )
404     drop truncate f->i fixnum-type
405 ; 1 make-fa-primitive flo:truncate->exact
406
407 :noname ( flonum -- flonum )
408     drop f->i fixnum-type
409 ; 1 make-fa-primitive flo:round->exact
410
411 :noname ( flonum flonum -- flonum )
412     drop swap drop f/ fatan flonum-type
413 ; 2 make-fa-primitive flo:atan2
414
415 \ --- Rationals ---
416
417 ' make-rational 2 make-fa-primitive make-rational
418
419 :noname ( ratnum -- fixnum )
420     drop pair-type car
421 ; 1 make-fa-primitive rat:numerator
422
423 :noname ( ratnum -- fixnum )
424     drop pair-type cdr
425 ; 1 make-fa-primitive rat:denominator
426
427 \ --- Conversion ---
428
429 :noname ( fixnum -- flonum )
430     drop i->f flonum-type
431 ; 1 make-fa-primitive fixnum->flonum
432
433 \ }}}
434
435 \ ==== Pairs and Lists ==== {{{
436
437 :noname ( arg1 arg2 -- pair )
438     cons
439 ; 2 make-fa-primitive cons
440
441 :noname ( pair-obj -- obj )
442     car
443 ; pair-type 1 make-fa-type-primitive car
444
445 :noname ( args -- obj )
446     cdr
447 ; pair-type 1 make-fa-type-primitive cdr
448
449 :noname ( pair obj  -- ok )
450     2swap pair-type ensure-arg-type
451
452     set-car!
453
454     ok-symbol
455 ; 2 make-fa-primitive set-car!
456
457 :noname ( pair obj -- ok )
458     2swap pair-type ensure-arg-type
459
460     set-cdr!
461
462     ok-symbol
463 ; 2 make-fa-primitive set-cdr!
464
465 \ }}}
466
467 \ ==== Polymorphic equality testing ==== {{{
468
469 :noname ( arg1 arg2 -- bool )
470     objeq? boolean-type
471 ; 2 make-fa-primitive eq?
472
473 \ }}}
474
475 \ ==== Input/Output ==== {{{
476
477 :noname ( -- port )
478     console-i/o-port obj@
479 ; 0 make-fa-primitive console-i/o-port
480
481 :noname ( -- port )
482     current-input-port obj@
483 ; 0 make-fa-primitive current-input-port
484
485 :noname ( args -- charobj )
486     nil? if
487         2drop current-input-port obj@
488     else
489         car port-type ensure-arg-type
490     then
491
492     read-char
493 ; make-primitive read-char
494
495 :noname ( args -- charobj )
496     nil? if
497         2drop current-input-port obj@
498     else
499         car port-type ensure-arg-type
500     then
501
502     peek-char
503 ; make-primitive peek-char
504
505 :noname ( args -- stringobj )
506     nil? if
507         2drop current-input-port obj@
508     else
509         car port-type ensure-arg-type
510     then
511
512     read-line
513 ; make-primitive read-line
514
515 : charlist>cstr ( charlist addr -- n )
516
517     dup 2swap ( origaddr addr charlist )
518
519     begin 
520         nil? false =
521     while
522         2dup cdr 2swap car 
523         drop ( origaddr addr charlist char )
524         -rot 2swap ( origaddr charlist addr char )
525         over !
526         1+ -rot ( origaddr nextaddr charlist )
527     repeat
528
529     2drop ( origaddr finaladdr ) 
530     swap -
531 ;
532
533 :noname ( args -- finalResult )
534     drop pair-type
535     pad charlist>cstr
536     pad swap load
537 ; string-type 1 make-fa-type-primitive load
538
539 :noname ( args -- obj )
540     read
541 ; 0 make-fa-primitive read
542
543 defer display
544
545 :noname ( obj -- none )
546     print none
547 ; 1 make-fa-primitive write
548
549 : displaypair ( pairobj -- )
550     2dup
551     car display
552     cdr
553     nil? if 2drop exit then
554     pair-type istype? if space recurse exit then
555     ."  . " display
556 ;
557
558 : displaychar ( charobj -- )
559     drop emit ;
560
561 : (displaystring) ( charlist -- )
562     nil? if
563         2drop
564     else
565         2dup car displaychar
566         cdr recurse
567     then
568 ;
569
570 : displaystring ( stringobj -- )
571     drop pair-type (displaystring)
572 ;
573
574 :noname ( obj -- )
575     pair-type istype? if ." (" displaypair ." )" exit then
576     character-type istype? if displaychar exit then
577     string-type istype? if displaystring exit then
578     
579     print
580 ; is display
581
582 :noname ( stringobj -- none )
583     displaystring none
584 ; string-type 1 make-fa-type-primitive display-string
585
586 :noname ( charobj -- none )
587     displaychar none
588 ; character-type 1 make-fa-type-primitive display-character
589
590 :noname ( obj -- none )
591     display none
592 ; 1 make-fa-primitive display
593
594 :noname ( args -- none )
595     cr none
596 ; 0 make-fa-primitive newline
597
598 \ }}}
599
600 \ ==== Evaluation ==== {{{
601
602 :noname ( args -- result )
603     2dup car 2swap cdr
604  
605     nil? false = if car then ( proc argvals )
606      
607     2swap apply
608 ; make-primitive apply 
609
610 :noname ( proc -- result )
611     make-continuation
612
613     ( Note that we get to this point either when
614     make-continuation is originally called or when
615     restore-continuation is called.  Since we don't
616     want to call proc again following a restore,
617     we use the boolean values placed on the parameter
618     stack by make-continuation and restore-continuation
619     to detect which call got us here and act accordingly. )
620
621     drop if
622         nil cons
623         2swap apply
624     else
625         2swap 2drop
626     then
627
628 ; 1 make-fa-primitive call-with-current-continuation
629
630 \ }}}
631
632 \ ==== Miscellaneous  ==== {{{
633
634 ( Produce a recoverable exception. )
635 :noname ( args -- result )
636     bold fg red
637
638     nil? if
639         ." Error."
640     else
641         ." Error:"
642
643         2dup car space display
644         cdr nil? invert if
645             begin
646                 2dup car space print
647                 cdr nil?
648             until
649         then
650
651         2drop
652     then
653
654     reset-term
655
656     recoverable-exception throw
657 ; make-primitive error
658
659 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
660 :noname ( args -- result )
661     [char] _  character-type nil cons
662     drop symbol-type
663 ; 0 make-fa-primitive gensym
664
665 ( Generate the NONE object indicating an unspecified return value. )
666 :noname ( args -- result )
667     none
668 ; 0 make-fa-primitive none
669
670 \ }}}
671
672 \ vim:fdm=marker