From: Tim Vaughan <tgvaughan@gmail.com>
Date: Mon, 31 Oct 2016 10:50:23 +0000 (+1300)
Subject: Added display primitives.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=480095585b96fbcc5a4fb58fb57188609aadb6e5;p=scheme.forth.jl.git

Added display primitives.
---

diff --git a/testing.scm b/scheme-library.scm
similarity index 83%
rename from testing.scm
rename to scheme-library.scm
index 0b7d95b..207bb30 100644
--- a/testing.scm
+++ b/scheme-library.scm
@@ -1,22 +1,8 @@
-;; Some simple procedures useful for implementation testing.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Standard Library Procedures and Macros ;; 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-; Basic iterative summation.  Run this on large numbers to
-; test garbage collection and tail-call optimization.
-(define (sum n)
-
-  (define (sum-iter total count maxcount)
-    (if (> count maxcount)
-      total
-      (sum-iter (+ total count) (+ count 1) maxcount)))
-  
-  (sum-iter 0 1 n))
-
-; Recursive summation. Use this to compare with tail call
-; optimized iterative algorithm.
-(define (sum-recurse n)
-  (if (= n 0)
-    0
-    (+ n (sum-recurse (- n 1)))))
+;; LISTS
 
 (define (null? args)
   (eq? args ()))
@@ -35,6 +21,27 @@
       (car lists)
       (join (car lists) (apply append (cdr lists))))))
 
-; Macro definitions
+
+;; LIBRARY FORMS
 (define-macro (let value . body )
               (list (list 'lambda (list (car value)) body)) (cdr value))
+
+;; TESTING
+
+; Basic iterative summation.  Run this on large numbers to
+; test garbage collection and tail-call optimization.
+(define (sum n)
+
+  (define (sum-iter total count maxcount)
+    (if (> count maxcount)
+      total
+      (sum-iter (+ total count) (+ count 1) maxcount)))
+  
+  (sum-iter 0 1 n))
+
+; Recursive summation. Use this to compare with tail call
+; optimized iterative algorithm.
+(define (sum-recurse n)
+  (if (= n 0)
+    0
+    (+ n (sum-recurse (- n 1)))))
diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 56ecab0..e446b2e 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -354,7 +354,8 @@ hide relcfa
 
 ' read make-primitive read
 
-:noname ( args -- )
+defer display
+:noname ( args -- none )
     2dup 1 ensure-arg-count
 
     car print cr
@@ -362,6 +363,62 @@ hide relcfa
     none
 ; make-primitive write
 
+: displaypair ( pairobj -- )
+    2dup
+    car display
+    cdr
+    nil-type istype? if 2drop exit then
+    pair-type istype? if space recurse exit then
+    ."  . " display
+;
+
+: displaychar ( charobj -- )
+    drop emit
+;
+
+:noname ( obj -- )
+    pair-type istype? if ." (" displaypair ." )" exit then
+    character-type istype? if displaychar exit then
+    string-type istype? if (printstring) exit then
+    
+    print
+; is display
+
+:noname ( args -- none )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    (printstring) cr
+
+    none
+; make-primitive display-string
+
+:noname ( args -- none )
+    2dup 1 ensure-arg-count
+    car character-type ensure-arg-type
+
+    displaychar cr
+
+    none
+; make-primitive display-character
+
+:noname ( args -- none )
+    2dup 1 ensure-arg-count
+    car
+
+    display cr
+
+    none
+; make-primitive display
+
+:noname ( args -- none )
+    0 ensure-arg-count
+
+    cr
+
+    none
+; make-primitive newline
+
 ( ==== Evaluation ==== )
 
 :noname 
diff --git a/scheme.4th b/scheme.4th
index f96fec9..64d4b40 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -1620,6 +1620,12 @@ include scheme-primitives.4th
 
 \ }}}
 
+\ ---- Standard Library ---- {{{
+
+    s" scheme-library.scm" load 2drop
+    
+\ }}}
+
 \ ---- REPL ----
 
 : repl