-\ ==== 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
+ ratnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive ratnum?
- car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+:noname ( args -- boolobj )
+ character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
+ string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
- car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+:noname ( args -- boolobj )
+ pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
:noname ( args -- boolobj )
- 2dup 1 ensure-arg-count
+ primitive-proc-type istype? if
+ true
+ else
+ compound-proc-type istype?
+ then
+
+ -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
- car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+:noname ( args -- boolobj )
+ port-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive port?
\ }}}
charlist>symbol
; make-primitive string->symbol
-\ }}}
-
-\ ==== Arithmetic ==== {{{
+:noname ( charlist -- string )
+ 2dup 1 ensure-arg-count
-: add-prim ( args -- fixnum )
- 2dup nil objeq? if
+ car nil? if
2drop
- 0 fixnum-type
- else
- 2dup car drop
- -rot cdr recurse drop
- + fixnum-type
+ nil nil cons
+ drop string-type
+ exit
then
-;
-' add-prim make-primitive +
+
+ pair-type ensure-arg-type
-: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 -
+ duplicate-charlist
+ drop string-type
+; make-primitive list->string
-:noname ( args -- fixnum )
- 2dup nil objeq? if
- 2drop
- 1 fixnum-type
+:noname ( string -- charlist )
+ 2dup 1 ensure-arg-count
+ car string-type ensure-arg-type
+
+ drop pair-type
+
+ 2dup car nil? if
+ 2swap 2drop
else
- 2dup car drop
- -rot cdr recurse drop
- * fixnum-type
+ 2drop
+ duplicate-charlist
then
-; make-primitive *
-:noname ( args -- fixnum )
- 2dup 2 ensure-arg-count
+; make-primitive string->list
- 2dup car fixnum-type ensure-arg-type
- 2swap cdr car fixnum-type ensure-arg-type
+\ }}}
- drop swap drop
+\ ==== Numeric types ==== {{{
- / fixnum-type
-; make-primitive quotient
+\ --- Fixnums ---
-:noname ( args -- fixnum )
- 2dup 2 ensure-arg-count
+:noname ( fixnum fixnum -- boolobj )
+ objeq? 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 swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
-: test-relation ( args -- bool )
+:noname ( fixnum -- boolobj )
+ drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
- 2dup nil objeq? if
- 2drop
- true boolean-type exit
- then
+:noname ( fixnum -- boolobj )
+ drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
- ( args )
+:noname ( fixnum -- boolobj )
+ drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
- 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:*
- 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 / fixnum-type
+; 2 make-fa-primitive fix:quotient
- 2swap cdr ( arg0 args'' )
- repeat
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
- 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-1 )
+ swap 1- swap
+; 1 make-fa-primitive fix:-1+
-:noname
- ['] fixnum-lt relcfa !
- test-relation
-; make-primitive <
+:noname ( fixnum -- -fixnum )
+ swap negate swap
+; 1 make-fa-primitive fix:neg
-: fixnum-gt ( obj1 obj2 -- bool )
- drop swap drop >
-;
+:noname ( fixnum -- -fixnum )
+ swap abs swap
+; 1 make-fa-primitive fix:abs
-:noname
- ['] fixnum-gt relcfa !
- test-relation
-; make-primitive >
+:noname ( fixnum fixnum -- fixnum' )
+ drop swap drop gcd fixnum-type
+; 2 make-fa-primitive fix:gcd
-: fixnum-eq ( obj1 obj2 -- bool )
- drop swap drop =
-;
+\ --- Flonums ---
-:noname
- ['] fixnum-eq relcfa !
- test-relation
-; make-primitive =
+:noname ( flonum flonum -- bool )
+ objeq? boolean-type
+; 2 make-fa-primitive flo:=
-hide relcfa
+: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:>
-\ ==== Pairs and Lists ==== {{{
+:noname ( flonum flonum -- bool )
+ drop swap drop f<= boolean-type
+; 2 make-fa-primitive flo:<=
-:noname ( args -- pair )
- 2dup 2 ensure-arg-count
+:noname ( flonum flonum -- bool )
+ drop swap drop f>= boolean-type
+; 2 make-fa-primitive flo:>=
- 2dup car 2swap cdr car
- cons
-; make-primitive cons
+:noname ( flonum -- bool )
+ drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
-:noname ( args -- list )
- \ args is already a list!
-; make-primitive list
+:noname ( flonum -- bool )
+ drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
-:noname ( args -- obj )
- 2dup 1 ensure-arg-count
- car pair-type ensure-arg-type
+: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
+
+\ }}}
+
+\ ==== 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
+: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
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
\ }}}
: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
( 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