From: Tim Vaughan 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