\ ==== 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
\ }}}
The Lambda Lab / projects / scheme.forth.jl.git / blobdiff