Working on quasiquote.

[scheme.forth.jl.git] / scheme-primitives.4th

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 56ecab0..86fbbd9 100644 (file)
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -352,20 +352,110 @@ hide relcfa
     pad swap load
 ; make-primitive load
 
-' read make-primitive read
+:noname ( args -- obj )
+    0 ensure-arg-count
+    read
+; make-primitive read
 
-:noname ( args -- )
+defer display
+:noname ( args -- none )
     2dup 1 ensure-arg-count
 
-    car print cr
+    car print
 
     none
 ; make-primitive write
 
+: displaypair ( pairobj -- )
+    2dup
+    car display
+    cdr
+    nil? if 2drop exit then
+    pair-type istype? if space recurse exit then
+    ."  . " display
+;
+
+: displaychar ( charobj -- )
+    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 displaystring exit then
+    
+    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
+
+    display
+
+    none
+; make-primitive display
+
+:noname ( args -- none )
+    0 ensure-arg-count
+
+    cr
+
+    none
+; make-primitive newline
+
 ( ==== Evaluation ==== )
 
-:noname 
-    \ Dummy apply procedure
-    \ Should never actually run!
-    ." Error: Dummy apply procedure executed!" cr
-; make-primitive apply
+: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