X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme-primitives.4th;h=86fbbd9749606e2e1ef6d1ffed3c7cd34db69c85;hb=82b93d081309895fe1a8e446daad5b8a75896fa3;hp=89e379e6efa893bcf2d6fdfa773d147dd4d2107c;hpb=7d3d7e571901f7191ce548600b51e97f30f8a225;p=scheme.forth.jl.git

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 89e379e..86fbbd9 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -352,13 +352,16 @@ hide relcfa
     pad swap load
 ; make-primitive load
 
-' read make-primitive read
+:noname ( args -- obj )
+    0 ensure-arg-count
+    read
+; make-primitive read
 
 defer display
 :noname ( args -- none )
     2dup 1 ensure-arg-count
 
-    car print cr
+    car print
 
     none
 ; make-primitive write
@@ -367,19 +370,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 +403,7 @@ defer display
     2dup 1 ensure-arg-count
     car string-type ensure-arg-type
 
-    (printstring) cr
+    displaystring
 
     none
 ; make-primitive display-string
@@ -397,7 +412,7 @@ defer display
     2dup 1 ensure-arg-count
     car character-type ensure-arg-type
 
-    displaychar cr
+    displaychar
 
     none
 ; make-primitive display-character
@@ -406,7 +421,7 @@ defer display
     2dup 1 ensure-arg-count
     car
 
-    display cr
+    display
 
     none
 ; make-primitive display
@@ -418,3 +433,29 @@ defer display
 
     none
 ; make-primitive newline
+
+( ==== Evaluation ==== )
+
+:noname ( args -- result )
+    2dup car 2swap cdr
+
+    nil? false = if car then ( proc argvals )
+    
+    apply
+; make-primitive apply 
+
+( ==== Error System ==== )
+
+:noname ( args -- result )
+    bold fg red
+
+    nil? if
+        ." Error."
+    else
+        ." Error: " car display
+    then
+
+    reset-term
+
+    recoverable-exception throw
+; make-primitive error