\ ==== Type predicates ==== {{{
: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?
+ character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+ string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+ pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
-
- car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+ primitive-proc-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
\ }}}
\ }}}
-\ ==== Arithmetic ==== {{{
-
-: add-prim ( args -- fixnum )
- 2dup nil objeq? if
- 2drop
- 0 fixnum-type
- else
- 2dup car drop
- -rot cdr recurse drop
- + fixnum-type
- then
-;
-' 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 -
-
-: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 ( args -- fixnum )
- 2dup 2 ensure-arg-count
-
- 2dup car fixnum-type ensure-arg-type
- 2swap cdr car fixnum-type ensure-arg-type
+\ ==== Primitivle Arithmetic ==== {{{
- drop swap drop
+\ --- Fixnums ---
- / fixnum-type
-; make-primitive quotient
+:noname ( fixnum fixnum -- boolobj )
+ objeq? boolean-type
+; 2 make-fa-primitive fix:=
-:noname ( args -- fixnum )
- 2dup 2 ensure-arg-count
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop < boolean-type
+; 2 make-fa-primitive fix:<
- 2dup car fixnum-type ensure-arg-type
- 2swap cdr car fixnum-type ensure-arg-type
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop > boolean-type
+; 2 make-fa-primitive fix:>
- drop swap drop
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop <= boolean-type
+; 2 make-fa-primitive fix:<=
- mod fixnum-type
-; make-primitive remainder
+:noname ( fixnum fixnum -- boolobj )
+ drop swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
-variable relcfa
+:noname ( fixnum fixnum -- boolobj )
+ drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
-: test-relation ( args -- bool )
+:noname ( fixnum fixnum -- boolobj )
+ drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
- 2dup nil objeq? if
- 2drop
- true boolean-type exit
- then
+:noname ( fixnum fixnum -- boolobj )
+ drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
- ( args )
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop + fixnum-type
+; 2 make-fa-primitive fix:+
- 2dup car fixnum-type ensure-arg-type ( args arg0 )
- 2swap cdr ( arg0 args' )
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop - fixnum-type
+; 2 make-fa-primitive fix:-
- 2dup nil objeq? if
- 2drop 2drop
- true boolean-type exit
- then
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop * fixnum-type
+; 2 make-fa-primitive fix:*
- ( arg0 args' )
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop / fixnum-type
+; 2 make-fa-primitive fix:quotient
- 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 ( fixnum fixnum -- fixnum' )
+ drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
- 2swap cdr ( arg0 args'' )
- repeat
+:noname ( fixnum -- fixnum+1 )
+ swap 1+ swap
+; 1 make-fa-primitive fix:1+
- 2drop 2drop
- true boolean-type
-;
+:noname ( fixnum -- fixnum-1 )
+ swap 1- swap
+; 1 make-fa-primitive fix:-1+
-: fixnum-lt ( obj1 obj2 -- bool )
- drop swap drop <
-;
+:noname ( fixnum -- -fixnum )
+ swap negate swap
+; 1 make-fa-primitive fix:neg
-:noname
- ['] fixnum-lt relcfa !
- test-relation
-; make-primitive <
-
-: fixnum-gt ( obj1 obj2 -- bool )
- drop swap drop >
-;
-
-:noname
- ['] fixnum-gt relcfa !
- test-relation
-; make-primitive >
-
-: fixnum-eq ( obj1 obj2 -- bool )
- drop swap drop =
+( Find the GCD of n1 and n2 where n2 < n1. )
+: gcd ( n1 n2 -- m )
+
;
-:noname
- ['] fixnum-eq relcfa !
- test-relation
-; make-primitive =
-
-hide relcfa
-
\ }}}
\ ==== Pairs and Lists ==== {{{
-:noname ( args -- pair )
- 2dup 2 ensure-arg-count
-
- 2dup car 2swap cdr car
+:noname ( arg1 arg2 -- pair )
cons
-; make-primitive cons
-
-:noname ( args -- list )
- \ args is already a list!
-; make-primitive list
-
-:noname ( args -- obj )
- 2dup 1 ensure-arg-count
- car pair-type ensure-arg-type
+; 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
-
- displaystring
-
- none
-; make-primitive display-string
-
-: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
+:noname ( stringobj -- none )
+ displaystring none
+; string-type 1 make-fa-type-primitive display-string
- display
+:noname ( charobj -- none )
+ displaychar none
+; character-type 1 make-fa-type-primitive display-character
- none
-; make-primitive display
+:noname ( obj -- none )
+ display none
+; 1 make-fa-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
\ }}}
does> @ ;
make-type fixnum-type
-make-type realnum-type
make-type boolean-type
make-type character-type
make-type string-type
bl word
count
- \ 2dup ." Defining primitive " type ." ..." cr
-
cstr>charlist
charlist>symbol
then
;
+: ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
+ dup 0= if
+ drop nil objeq? false = if
+ recoverable-exception throw" Too many arguments for primitive procedure."
+ then
+ else
+ -rot nil? if
+ recoverable-exception throw" Too few arguments for primitive procedure."
+ then
+
+ 2dup cdr 2swap car ( ... t1 n args' arg1 )
+ 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
+ istype? false = if
+ recoverable-exception throw" Incorrect type for primitive procedure."
+ then
+
+ 2drop recurse
+ then
+
+;
+
+: push-args-to-stack ( args -- arg1 arg2 ... argn )
+ begin
+ nil? false =
+ while
+ 2dup car 2swap cdr
+ repeat
+
+ 2drop
+;
+
+: add-fa-checks ( cfa n -- cfa' )
+ here current @ 1+ dup @ , !
+ 0 ,
+ here -rot
+ docol ,
+ ['] 2dup , ['] lit , , ['] ensure-arg-count ,
+ ['] push-args-to-stack ,
+ ['] lit , , ['] execute ,
+ ['] exit ,
+;
+
+: add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
+ here current @ 1+ dup @ , !
+ 0 ,
+ here >R
+ docol ,
+ ['] 2dup ,
+ ['] >R , ['] >R ,
+
+ dup ( cfa t1 t2 ... tn n m )
+
+ begin
+ ?dup 0>
+ while
+ rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
+ 1-
+ repeat
+
+ ['] R> , ['] R> ,
+
+ ['] lit , , ['] ensure-arg-type-and-count ,
+
+ ['] push-args-to-stack ,
+ ['] lit , , ['] execute ,
+ ['] exit ,
+
+ R>
+;
+
+: make-fa-primitive ( cfa n -- )
+ add-fa-checks make-primitive ;
+
+: make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
+ add-fa-type-checks make-primitive ;
+
: arg-type-error
bold fg red ." Incorrect argument type." reset-term cr
abort
delim? pop-parse-idx
;
-: realnum? ( -- bool )
+: flonum? ( -- bool )
push-parse-idx
minus? plus? or if
fixnum-type
;
-: readrealnum ( -- realnum )
-
- \ Remember that at this point we're guaranteed to
- \ have a parsable real on this line.
-
- parse-str parse-idx @ +
-
- begin delim? false = while
- inc-parse-idx
- repeat
-
- parse-str parse-idx @ + over -
-
- float-parse
-
- realnum-type
-;
-
: readbool ( -- bool-obj )
inc-parse-idx
exit
then
- realnum? if
- readrealnum
- exit
- then
-
boolean? if
readbool
exit
: self-evaluating? ( obj -- obj bool )
boolean-type istype? if true exit then
fixnum-type istype? if true exit then
- realnum-type istype? if true exit then
character-type istype? if true exit then
string-type istype? if true exit then
nil-type istype? if true exit then
: printfixnum ( fixnumobj -- ) drop 0 .R ;
-: printrealnum ( realnumobj -- ) drop float-print ;
-
: printbool ( numobj -- )
drop if
." #t"
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
- realnum-type istype? if printrealnum exit then
boolean-type istype? if printbool exit then
character-type istype? if printchar exit then
string-type istype? if printstring exit then