-\ ==== Type predicates ==== {{{
+\ ==== Type predilcates ==== {{{
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car nil objeq? boolean-type
-; make-primitive null?
+ nil objeq? boolean-type
+; 1 make-fa-primitive null?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car boolean-type istype? -rot 2drop boolean-type
-; make-primitive boolean?
+ boolean-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive boolean?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car symbol-type istype? -rot 2drop boolean-type
-; make-primitive symbol?
+ symbol-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive symbol?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car fixnum-type istype? -rot 2drop boolean-type
-; make-primitive integer?
+ fixnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive fixnum?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car character-type istype? -rot 2drop boolean-type
-; make-primitive char?
+ flonum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive flonum?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+ character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+ string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
+ pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
- car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+:noname ( args -- boolobj )
+ primitive-proc-type istype? if
+ true
+ else
+ compound-proc-type istype?
+ then
+
+ -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
\ }}}
\ }}}
-\ ==== Arithmetic ==== {{{
+\ ==== Primitivle Arithmetic ==== {{{
-: add-prim ( args -- fixnum )
- 2dup nil objeq? if
- 2drop
- 0 fixnum-type
- else
- 2dup car drop
- -rot cdr recurse drop
- + fixnum-type
- then
+\ --- Fixnums ---
+
+:noname ( fixnum fixnum -- boolobj )
+ objeq? boolean-type
+; 2 make-fa-primitive fix:=
+
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop < boolean-type
+; 2 make-fa-primitive fix:<
+
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop > boolean-type
+; 2 make-fa-primitive fix:>
+
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop <= boolean-type
+; 2 make-fa-primitive fix:<=
+
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
+
+:noname ( fixnum -- boolobj )
+ drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
+
+:noname ( fixnum -- boolobj )
+ drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
+
+:noname ( fixnum -- boolobj )
+ drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop + fixnum-type
+; 2 make-fa-primitive fix:+
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop - fixnum-type
+; 2 make-fa-primitive fix:-
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop * fixnum-type
+; 2 make-fa-primitive fix:*
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop / fixnum-type
+; 2 make-fa-primitive fix:quotient
+
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
+
+:noname ( fixnum -- fixnum+1 )
+ swap 1+ swap
+; 1 make-fa-primitive fix:1+
+
+:noname ( fixnum -- fixnum-1 )
+ swap 1- swap
+; 1 make-fa-primitive fix:-1+
+
+:noname ( fixnum -- -fixnum )
+ swap negate swap
+; 1 make-fa-primitive fix:neg
+
+( Find the GCD of n1 and n2 where n2 < n1. )
+: gcd ( n1 n2 -- m )
+
;
-' add-prim make-primitive +
-:noname ( args -- fixnum )
- 2dup nil objeq? if
- 2drop
- 0 fixnum-type
- else
- 2dup car drop
- -rot cdr
- 2dup nil objeq? if
- 2drop negate
- else
- add-prim drop
- -
- then
- fixnum-type
- then
-; make-primitive -
+\ --- Flonums ---
-:noname ( args -- fixnum )
- 2dup nil objeq? if
- 2drop
- 1 fixnum-type
- else
- 2dup car drop
- -rot cdr recurse drop
- * fixnum-type
- then
-; make-primitive *
+:noname ( flonum flonum -- bool )
+ objeq? boolean-type
+; 2 make-fa-primitive flo:=
-:noname ( args -- fixnum )
- 2dup 2 ensure-arg-count
+:noname ( flonum flonum -- bool )
+ drop swap drop f< boolean-type
+; 2 make-fa-primitive flo:<
- 2dup car fixnum-type ensure-arg-type
- 2swap cdr car fixnum-type ensure-arg-type
+:noname ( flonum flonum -- bool )
+ drop swap drop f> boolean-type
+; 2 make-fa-primitive flo:>
- drop swap drop
- / fixnum-type
-; make-primitive quotient
+:noname ( flonum -- bool )
+ drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
-:noname ( args -- fixnum )
- 2dup 2 ensure-arg-count
+:noname ( flonum -- bool )
+ drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
- 2dup car fixnum-type ensure-arg-type
- 2swap cdr car fixnum-type ensure-arg-type
+:noname ( flonum -- bool )
+ drop 0.0 f< boolean-type
+; 1 make-fa-primitive flo:negative?
- drop swap drop
- mod fixnum-type
-; make-primitive remainder
+:noname ( flonum1 flonum2 -- flonum1+flonum2 )
+ drop swap drop f+ flonum-type
+; 2 make-fa-primitive flo:+
-variable relcfa
+:noname ( flonum1 flonum2 -- flonum1-flonum2 )
+ drop swap drop f- flonum-type
+; 2 make-fa-primitive flo:-
-: test-relation ( args -- bool )
+:noname ( flonum1 flonum2 -- flonum1*flonum2 )
+ drop swap drop f* flonum-type
+; 2 make-fa-primitive flo:*
- 2dup nil objeq? if
- 2drop
- true boolean-type exit
- then
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+ drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
- ( args )
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+ drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
- 2dup car fixnum-type ensure-arg-type ( args arg0 )
- 2swap cdr ( arg0 args' )
- 2dup nil objeq? if
- 2drop 2drop
- true boolean-type exit
- then
+:noname ( flonum -- bool )
+ drop dup
+ fnan? swap finf? or invert
+; 1 make-fa-primitive flo:finite?
- ( arg0 args' )
- begin
- 2dup nil objeq? false =
- while
- 2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
- 2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
- relcfa @ execute false = if
- 2drop 2drop
- false boolean-type exit
- then
+:noname ( flonum -- flonum )
+ swap fabs swap
+; 1 make-fa-primitive flo:abs
- 2swap cdr ( arg0 args'' )
- repeat
+:noname ( flonum -- flonum )
+ swap fexp swap
+; 1 make-fa-primitive flo:exp
- 2drop 2drop
- true boolean-type
-;
+:noname ( flonum -- flonum )
+ swap flog swap
+; 1 make-fa-primitive flo:log
-: fixnum-lt ( obj1 obj2 -- bool )
- drop swap drop <
-;
+:noname ( flonum -- flonum )
+ swap fsin swap
+; 1 make-fa-primitive flo:sin
-:noname
- ['] fixnum-lt relcfa !
- test-relation
-; make-primitive <
+:noname ( flonum -- flonum )
+ swap fcos swap
+; 1 make-fa-primitive flo:cos
-: fixnum-gt ( obj1 obj2 -- bool )
- drop swap drop >
-;
+:noname ( flonum -- flonum )
+ swap ftan swap
+; 1 make-fa-primitive flo:tan
-:noname
- ['] fixnum-gt relcfa !
- test-relation
-; make-primitive >
+:noname ( flonum -- flonum )
+ swap fasin swap
+; 1 make-fa-primitive flo:asin
-: fixnum-eq ( obj1 obj2 -- bool )
- drop swap drop =
-;
+:noname ( flonum -- flonum )
+ swap facos swap
+; 1 make-fa-primitive flo:acos
-:noname
- ['] fixnum-eq relcfa !
- test-relation
-; make-primitive =
+:noname ( flonum -- flonum )
+ swap fatan swap
+; 1 make-fa-primitive flo:atan
-hide relcfa
+: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
-\ ==== Pairs and Lists ==== {{{
+:noname ( flonum -- flonum )
+ swap floor swap
+; 1 make-fa-primitive flo:floor
-:noname ( args -- pair )
- 2dup 2 ensure-arg-count
+:noname ( flonum -- flonum )
+ swap ceiling swap
+; 1 make-fa-primitive flo:ceiling
- 2dup car 2swap cdr car
- cons
-; make-primitive cons
+:noname ( flonum -- flonum )
+ swap truncate swap
+; 1 make-fa-primitive flo:truncate
-:noname ( args -- list )
- \ args is already a list!
-; make-primitive list
+:noname ( flonum -- flonum )
+ swap fround swap
+; 1 make-fa-primitive flo:round
-:noname ( args -- obj )
- 2dup 1 ensure-arg-count
- car pair-type ensure-arg-type
+: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
+
+\ }}}
+
+\ ==== Pairs and Lists ==== {{{
+
+:noname ( arg1 arg2 -- pair )
+ cons
+; 2 make-fa-primitive cons
+
+:noname ( pair-obj -- obj )
car
-; make-primitive car
+; pair-type 1 make-fa-type-primitive car
:noname ( args -- obj )
- 2dup 1 ensure-arg-count
- car pair-type ensure-arg-type
-
cdr
-; make-primitive cdr
+; pair-type 1 make-fa-type-primitive cdr
-:noname ( args -- ok )
- 2dup 2 ensure-arg-count
- 2dup cdr car
- 2swap car pair-type ensure-arg-type
+:noname ( pair obj -- ok )
+ 2swap pair-type ensure-arg-type
set-car!
ok-symbol
-; make-primitive set-car!
+; 2 make-fa-primitive set-car!
-:noname ( args -- ok )
- 2dup 2 ensure-arg-count
- 2dup cdr car
- 2swap car pair-type ensure-arg-type
+:noname ( pair obj -- ok )
+ 2swap pair-type ensure-arg-type
set-cdr!
ok-symbol
-; make-primitive set-cdr!
+; 2 make-fa-primitive set-cdr!
\ }}}
\ ==== Polymorphic equality testing ==== {{{
-:noname ( args -- bool )
- 2dup 2 ensure-arg-count
- 2dup cdr car
- 2swap car
-
+:noname ( arg1 arg2 -- bool )
objeq? boolean-type
-; make-primitive eq?
+; 2 make-fa-primitive eq?
\ }}}
\ ==== Input/Output ==== {{{
:noname ( args -- finalResult )
- 2dup 1 ensure-arg-count
- car string-type ensure-arg-type
-
drop pair-type
pad charlist>cstr
pad swap load
-; make-primitive load
+; string-type 1 make-fa-type-primitive load
:noname ( args -- obj )
- 0 ensure-arg-count
read
-; make-primitive read
+; 0 make-fa-primitive read
defer display
-:noname ( args -- none )
- 2dup 1 ensure-arg-count
- car print
-
- none
-; make-primitive write
+:noname ( obj -- none )
+ print none
+; 1 make-fa-primitive write
: displaypair ( pairobj -- )
2dup
print
; is display
-:noname ( args -- none )
- 2dup 1 ensure-arg-count
- car string-type ensure-arg-type
+:noname ( stringobj -- none )
+ displaystring none
+; string-type 1 make-fa-type-primitive display-string
- displaystring
+:noname ( charobj -- none )
+ displaychar none
+; character-type 1 make-fa-type-primitive display-character
- none
-; make-primitive display-string
+:noname ( obj -- none )
+ display none
+; 1 make-fa-primitive display
:noname ( args -- none )
- 2dup 1 ensure-arg-count
- car character-type ensure-arg-type
-
- displaychar
-
- none
-; make-primitive display-character
-
-:noname ( args -- none )
- 2dup 1 ensure-arg-count
- car
-
- display
-
- none
-; make-primitive display
-
-:noname ( args -- none )
- 0 ensure-arg-count
-
- cr
-
- none
-; make-primitive newline
+ cr none
+; 0 make-fa-primitive newline
\ }}}
( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
:noname ( args -- result )
- 0 ensure-arg-count
-
[char] _ character-type nil cons
drop symbol-type
-; make-primitive gensym
+; 0 make-fa-primitive gensym
( Generate the NONE object indicating an unspecified return value. )
:noname ( args -- result )
- 0 ensure-arg-count
-
none
-; make-primitive none
+; 0 make-fa-primitive none
\ }}}