include term-colours.4th
include defer-is.4th
include catch-throw.4th
+include integer.4th
include float.4th
include debugging.4th
does> @ ;
make-type fixnum-type
+make-type flonum-type
+make-type ratnum-type
make-type boolean-type
make-type character-type
make-type string-type
pop-parse-idx
;
+: ratnum? ( -- bool )
+ push-parse-idx
+
+ minus? plus? or if
+ inc-parse-idx
+ then
+
+ digit? invert if
+ pop-parse-idx false exit
+ else
+ inc-parse-idx
+ then
+
+ begin digit? while
+ inc-parse-idx
+ repeat
+
+ [char] / nextchar <> if
+ pop-parse-idx false exit
+ else
+ inc-parse-idx
+ then
+
+ digit? invert if
+ pop-parse-idx false exit
+ else
+ inc-parse-idx
+ then
+
+ begin digit? while
+ inc-parse-idx
+ repeat
+
+ delim? pop-parse-idx
+;
+
: boolean? ( -- bool )
nextchar [char] # <> if false exit then
: string? ( -- bool )
nextchar [char] " = ;
-: readfixnum ( -- num-atom )
+: readfixnum ( -- fixnum )
plus? minus? or if
minus?
inc-parse-idx
fixnum-type
;
+: readflonum ( -- flonum )
+ readfixnum drop
+ dup 0< swap abs i->f
+
+ [char] . nextchar = if
+ inc-parse-idx
+
+ 10.0 ( f exp )
+
+ begin digit? while
+ nextchar [char] 0 - i->f ( f exp d )
+ over f/ rot f+ ( exp f' )
+ swap 10.0 f* ( f' exp' )
+ inc-parse-idx
+ repeat
+
+ drop
+ then
+
+ [char] e nextchar = [char] E nextchar = or if
+ inc-parse-idx
+ 10.0
+ readfixnum drop i->f
+ f^ f*
+ then
+
+ swap if
+ -1.0 f*
+ then
+
+ flonum-type
+;
+
+: make-rational ( fixnum fixnum -- ratnum|fixnum )
+ drop swap drop
+ simplify
+
+ dup 1 = if
+ drop fixnum-type
+ else
+ fixnum-type swap fixnum-type
+ cons drop ratnum-type
+ then
+;
+
+: readratnum ( -- ratnum )
+ readfixnum inc-parse-idx readfixnum
+ make-rational
+;
+
: readbool ( -- bool-obj )
inc-parse-idx
exit
then
+ flonum? if
+ readflonum
+ exit
+ then
+
+ ratnum? if
+ readratnum
+ 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
+ flonum-type istype? if true exit then
+ ratnum-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
\ ---- Print ---- {{{
-: printfixnum ( fixnumobj -- ) drop 0 .R ;
+: printfixnum ( fixnum -- ) drop 0 .R ;
+
+: printflonum ( flonum -- ) drop f. ;
+
+: printratnum ( ratnum -- )
+ drop pair-type 2dup
+ car print ." /" cdr print
+;
-: printbool ( numobj -- )
+: printbool ( bool -- )
drop if
." #t"
else
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
+ flonum-type istype? if printflonum exit then
+ ratnum-type istype? if printratnum exit then
boolean-type istype? if printbool exit then
character-type istype? if printchar exit then
string-type istype? if printstring exit then