From: Tim Vaughan Date: Fri, 4 Nov 2016 23:51:44 +0000 (+1300) Subject: Fixed bug in (display) X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=988c879292acffbbf86367601c41ad7c010ff160;p=scheme.forth.jl.git Fixed bug in (display) --- diff --git a/scheme-primitives.4th b/scheme-primitives.4th index 97c098f..b71b98d 100644 --- a/scheme-primitives.4th +++ b/scheme-primitives.4th @@ -367,19 +367,31 @@ defer display 2dup car display cdr - nil-type istype? if 2drop exit then + nil? if 2drop exit then pair-type istype? if space recurse exit then ." . " display ; : displaychar ( charobj -- ) - drop emit + drop emit ; + +: (displaystring) ( charlist -- ) + nil? if + 2drop + else + 2dup car displaychar + cdr recurse + then +; + +: displaystring ( stringobj -- ) + drop pair-type (displaystring) ; :noname ( obj -- ) pair-type istype? if ." (" displaypair ." )" exit then character-type istype? if displaychar exit then - string-type istype? if (printstring) exit then + string-type istype? if displaystring exit then print ; is display @@ -388,7 +400,7 @@ defer display 2dup 1 ensure-arg-count car string-type ensure-arg-type - (printstring) + displaystring none ; make-primitive display-string diff --git a/scheme.4th b/scheme.4th index 4ccf7d8..f2d7375 100644 --- a/scheme.4th +++ b/scheme.4th @@ -1456,7 +1456,7 @@ hide env ; : (printstring) ( stringobj -- ) - nil-type istype? if 2drop exit then + nil? if 2drop exit then 2dup car drop dup case