-\ ==== Type predicates ==== {{{
+\ ==== Type predilcates ==== {{{
:noname ( args -- boolobj )
nil objeq? boolean-type
fixnum-type istype? -rot 2drop boolean-type
; 1 make-fa-primitive fixnum?
+:noname ( args -- boolobj )
+ flonum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive flonum?
+
+:noname ( args -- boolobj )
+ ratnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive ratnum?
+
:noname ( args -- boolobj )
character-type istype? -rot 2drop boolean-type
; 1 make-fa-primitive char?
-rot 2drop boolean-type
; 1 make-fa-primitive procedure?
+:noname ( args -- boolobj )
+ port-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive port?
+
\ }}}
\ ==== Type conversions ==== {{{
charlist>symbol
; make-primitive string->symbol
+:noname ( charlist -- string )
+ 2dup 1 ensure-arg-count
+
+ car nil? if
+ 2drop
+ nil nil cons
+ drop string-type
+ exit
+ then
+
+ pair-type ensure-arg-type
+
+ duplicate-charlist
+ drop string-type
+; make-primitive list->string
+
+:noname ( string -- charlist )
+ 2dup 1 ensure-arg-count
+ car string-type ensure-arg-type
+
+ drop pair-type
+
+ 2dup car nil? if
+ 2swap 2drop
+ else
+ 2drop
+ duplicate-charlist
+ then
+
+; make-primitive string->list
+
\ }}}
-\ ==== Primitivle Arithmetic ==== {{{
+\ ==== Numeric types ==== {{{
\ --- Fixnums ---
drop swap drop >= boolean-type
; 2 make-fa-primitive fix:>=
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
drop 0= boolean-type
; 1 make-fa-primitive fix:zero?
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
drop 0> boolean-type
; 1 make-fa-primitive fix:positive?
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
drop 0< boolean-type
; 1 make-fa-primitive fix:negative?
swap negate swap
; 1 make-fa-primitive fix:neg
-( Find the GCD of n1 and n2 where n2 < n1. )
-: gcd ( n1 n2 -- m )
-
-;
+:noname ( fixnum -- -fixnum )
+ swap abs swap
+; 1 make-fa-primitive fix:abs
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop gcd fixnum-type
+; 2 make-fa-primitive fix:gcd
+
+\ --- Flonums ---
+
+:noname ( flonum flonum -- bool )
+ objeq? boolean-type
+; 2 make-fa-primitive flo:=
+
+:noname ( flonum flonum -- bool )
+ drop swap drop f< boolean-type
+; 2 make-fa-primitive flo:<
+
+:noname ( flonum flonum -- bool )
+ drop swap drop f> boolean-type
+; 2 make-fa-primitive flo:>
+
+:noname ( flonum flonum -- bool )
+ drop swap drop f<= boolean-type
+; 2 make-fa-primitive flo:<=
+
+:noname ( flonum flonum -- bool )
+ drop swap drop f>= boolean-type
+; 2 make-fa-primitive flo:>=
+
+:noname ( flonum -- bool )
+ drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
+
+:noname ( flonum -- bool )
+ drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
+
+:noname ( flonum -- bool )
+ drop 0.0 f< boolean-type
+; 1 make-fa-primitive flo:negative?
+
+
+:noname ( flonum1 flonum2 -- flonum1+flonum2 )
+ drop swap drop f+ flonum-type
+; 2 make-fa-primitive flo:+
+
+:noname ( flonum1 flonum2 -- flonum1-flonum2 )
+ drop swap drop f- flonum-type
+; 2 make-fa-primitive flo:-
+
+:noname ( flonum1 flonum2 -- flonum1*flonum2 )
+ drop swap drop f* flonum-type
+; 2 make-fa-primitive flo:*
+
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+ drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
+
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+ drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
+
+
+:noname ( flonum -- bool )
+ drop dup
+ fnan? swap finf? or invert
+; 1 make-fa-primitive flo:finite?
+
+
+:noname ( flonum -- flonum )
+ swap -1.0 f* swap
+; 1 make-fa-primitive flo:neg
+
+:noname ( flonum -- flonum )
+ swap fabs swap
+; 1 make-fa-primitive flo:abs
+
+:noname ( flonum -- flonum )
+ swap fexp swap
+; 1 make-fa-primitive flo:exp
+
+:noname ( flonum -- flonum )
+ swap flog swap
+; 1 make-fa-primitive flo:log
+
+:noname ( flonum -- flonum )
+ swap fsin swap
+; 1 make-fa-primitive flo:sin
+
+:noname ( flonum -- flonum )
+ swap fcos swap
+; 1 make-fa-primitive flo:cos
+
+:noname ( flonum -- flonum )
+ swap ftan swap
+; 1 make-fa-primitive flo:tan
+
+:noname ( flonum -- flonum )
+ swap fasin swap
+; 1 make-fa-primitive flo:asin
+
+:noname ( flonum -- flonum )
+ swap facos swap
+; 1 make-fa-primitive flo:acos
+
+:noname ( flonum -- flonum )
+ swap fatan swap
+; 1 make-fa-primitive flo:atan
+
+:noname ( flonum -- flonum )
+ swap fsqrt swap
+; 1 make-fa-primitive flo:sqrt
+
+:noname ( flonum flonum -- flonum )
+ drop swap drop f^ flonum-type
+; 2 make-fa-primitive flo:expt
+
+:noname ( flonum -- flonum )
+ swap floor swap
+; 1 make-fa-primitive flo:floor
+
+:noname ( flonum -- flonum )
+ swap ceiling swap
+; 1 make-fa-primitive flo:ceiling
+
+:noname ( flonum -- flonum )
+ swap truncate swap
+; 1 make-fa-primitive flo:truncate
+
+:noname ( flonum -- flonum )
+ swap fround swap
+; 1 make-fa-primitive flo:round
+
+:noname ( flonum -- flonum )
+ drop floor f->i fixnum-type
+; 1 make-fa-primitive flo:floor->exact
+
+:noname ( flonum -- flonum )
+ drop ceiling f->i fixnum-type
+; 1 make-fa-primitive flo:ceiling->exact
+
+:noname ( flonum -- flonum )
+ drop truncate f->i fixnum-type
+; 1 make-fa-primitive flo:truncate->exact
+
+:noname ( flonum -- flonum )
+ drop f->i fixnum-type
+; 1 make-fa-primitive flo:round->exact
+
+:noname ( flonum flonum -- flonum )
+ drop swap drop f/ fatan flonum-type
+; 2 make-fa-primitive flo:atan2
+
+\ --- Rationals ---
+
+' make-rational 2 make-fa-primitive make-rational
+
+:noname ( ratnum -- fixnum )
+ drop pair-type car
+; 1 make-fa-primitive rat:numerator
+
+:noname ( ratnum -- fixnum )
+ drop pair-type cdr
+; 1 make-fa-primitive rat:denominator
+
+\ --- Conversion ---
+
+:noname ( fixnum -- flonum )
+ drop i->f flonum-type
+; 1 make-fa-primitive fixnum->flonum
\ }}}
\ ==== Input/Output ==== {{{
+:noname ( -- port )
+ console-i/o-port obj@
+; 0 make-fa-primitive console-i/o-port
+
+:noname ( -- port )
+ current-input-port obj@
+; 0 make-fa-primitive current-input-port
+
+:noname ( args -- charobj )
+ nil? if
+ 2drop current-input-port obj@
+ else
+ car port-type ensure-arg-type
+ then
+
+ read-char
+; make-primitive read-char
+
+:noname ( args -- charobj )
+ nil? if
+ 2drop current-input-port obj@
+ else
+ car port-type ensure-arg-type
+ then
+
+ peek-char
+; make-primitive peek-char
+
+:noname ( args -- stringobj )
+ nil? if
+ 2drop current-input-port obj@
+ else
+ car port-type ensure-arg-type
+ then
+
+ read-line
+; make-primitive read-line
+
+: charlist>cstr ( charlist addr -- n )
+
+ dup 2swap ( origaddr addr charlist )
+
+ begin
+ nil? false =
+ while
+ 2dup cdr 2swap car
+ drop ( origaddr addr charlist char )
+ -rot 2swap ( origaddr charlist addr char )
+ over !
+ 1+ -rot ( origaddr nextaddr charlist )
+ repeat
+
+ 2drop ( origaddr finaladdr )
+ swap -
+;
+
:noname ( args -- finalResult )
drop pair-type
pad charlist>cstr
:noname ( args -- result )
2dup car 2swap cdr
-
+
nil? false = if car then ( proc argvals )
-
- apply
+
+ 2swap apply
; make-primitive apply
+:noname ( proc -- result )
+ make-continuation
+
+ drop if
+ nil cons
+ 2swap apply
+ else
+ 2swap 2drop
+ then
+
+; 1 make-fa-primitive call-with-current-continuation
+
\ }}}
\ ==== Miscellaneous ==== {{{
nil? if
." Error."
else
- ." Error: " car display
+ ." Error:"
+
+ 2dup car space display
+ cdr nil? invert if
+ begin
+ 2dup car space print
+ cdr nil?
+ until
+ then
+
+ 2drop
then
reset-term