From 7e44c5ca79a16106aefa315ccf38e74dcd365554 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Mon, 31 Oct 2016 15:05:58 +1300 Subject: [PATCH] Added testing code back in. --- scheme-primitives.4th | 39 ++++++++++++-- scheme.4th | 122 ++++++++++++++++++++++-------------------- testing.scm | 40 ++++++++++++++ 3 files changed, 138 insertions(+), 63 deletions(-) create mode 100644 testing.scm diff --git a/scheme-primitives.4th b/scheme-primitives.4th index 1d2e21c..56ecab0 100644 --- a/scheme-primitives.4th +++ b/scheme-primitives.4th @@ -1,4 +1,4 @@ -( = Type predicates = ) +( ==== Type predicates ==== ) :noname ( args -- boolobj ) 2dup 1 ensure-arg-count @@ -48,7 +48,7 @@ car primitive-proc-type istype? -rot 2drop boolean-type ; make-primitive procedure? -( = Type conversions = ) +( ==== Type conversions ==== ) :noname ( args -- fixnum ) 2dup 1 ensure-arg-count @@ -153,7 +153,7 @@ charlist>symbol ; make-primitive string->symbol -( = Arithmetic = ) +( ==== Arithmetic ==== ) : add-prim ( args -- fixnum ) 2dup nil objeq? if @@ -284,7 +284,7 @@ variable relcfa hide relcfa -( = Pairs and Lists = ) +( ==== Pairs and Lists ==== ) :noname ( args -- pair ) 2dup 2 ensure-arg-count @@ -331,7 +331,7 @@ hide relcfa ok-symbol ; make-primitive set-cdr! -( = Polymorphic equality testing = ) +( ==== Polymorphic equality testing ==== ) :noname ( args -- bool ) 2dup 2 ensure-arg-count @@ -340,3 +340,32 @@ hide relcfa objeq? boolean-type ; make-primitive eq? + +( ==== Input/Output ==== ) + +:noname ( args -- finalResult ) + 2dup 1 ensure-arg-count + car string-type ensure-arg-type + + drop pair-type + pad charlist>cstr + pad swap load +; make-primitive load + +' read make-primitive read + +:noname ( args -- ) + 2dup 1 ensure-arg-count + + car print cr + + none +; make-primitive write + +( ==== Evaluation ==== ) + +:noname + \ Dummy apply procedure + \ Should never actually run! + ." Error: Dummy apply procedure executed!" cr +; make-primitive apply diff --git a/scheme.4th b/scheme.4th index 8c5b159..f96fec9 100644 --- a/scheme.4th +++ b/scheme.4th @@ -1188,7 +1188,7 @@ hide env 2swap ; -: apply ( proc argvals ) +: apply ( proc argvals -- result ) 2swap dup case primitive-proc-type of drop execute @@ -1210,11 +1210,24 @@ hide env R> drop ['] eval goto-deferred \ Tail call optimization endof - bold fg red ." Object not applicable. Aboring." reset-term cr + bold fg red ." Object not applicable. Aborting." reset-term cr abort endcase ; +: macro-expand ( proc expbody -- result ) + 2swap + 2dup procedure-body ( expbody proc procbody ) + -2rot 2dup procedure-params ( procbody expbody proc argnames ) + -2rot procedure-env ( procbody argnames expbody procenv ) + + -2rot 2swap + flatten-proc-args + 2swap 2rot + + extend-env eval-sequence eval +; + :noname ( obj env -- result ) 2swap @@ -1296,13 +1309,15 @@ hide env else \ Macro function evaluation - ." Macro eval" - ( env exp env opname mproc ) 2swap 2drop -2rot 2drop cdr ( env mproc body ) - \ TODO: evaluate macro procedure on expression body - ." ABORTED: Macros not yet fully implemented!" abort + 2dup print cr + macro-expand + 2dup print cr + + 2swap + ['] eval goto-deferred then exit then @@ -1507,6 +1522,49 @@ variable gc-stack-depth \ }}} +\ ---- Loading files ---- {{{ + +: charlist>cstr ( charlist addr -- n ) + + dup 2swap ( origaddr addr charlist ) + + begin + nil? false = + while + 2dup cdr 2swap car + drop ( origaddr addr charlist char ) + -rot 2swap ( origaddr charlist addr char ) + over ! + 1+ -rot ( origaddr nextaddr charlist ) + repeat + + 2drop ( origaddr finaladdr ) + swap - +; + +: load ( addr n -- finalResult ) + open-input-file + + empty-parse-str + + ok-symbol ( port res ) + + begin + 2over read-port ( port res obj ) + + 2dup EOF character-type objeq? if + 2drop 2swap close-port + exit + then + + 2swap 2drop ( port obj ) + + global-env obj@ eval ( port res ) + again +; + +\ }}} + \ ---- Primitives ---- {{{ : make-primitive ( cfa -- ) @@ -1562,58 +1620,6 @@ include scheme-primitives.4th \ }}} -\ ---- Loading files ---- {{{ - -: charlist>cstr ( charlist addr -- n ) - - dup 2swap ( origaddr addr charlist ) - - begin - nil? false = - while - 2dup cdr 2swap car - drop ( origaddr addr charlist char ) - -rot 2swap ( origaddr charlist addr char ) - over ! - 1+ -rot ( origaddr nextaddr charlist ) - repeat - - 2drop ( origaddr finaladdr ) - swap - -; - -: load ( addr n -- finalResult ) - open-input-file - - empty-parse-str - - ok-symbol ( port res ) - - begin - 2over read-port ( port res obj ) - - 2dup EOF character-type objeq? if - 2drop 2swap close-port - exit - then - - 2swap 2drop ( port obj ) - - global-env obj@ eval ( port res ) - again -; - -:noname ( args -- finalResult ) - 2dup 1 ensure-arg-count - car string-type ensure-arg-type - - drop pair-type - pad charlist>cstr - pad swap load -; make-primitive load - -\ }}} - \ ---- REPL ---- : repl diff --git a/testing.scm b/testing.scm new file mode 100644 index 0000000..0b7d95b --- /dev/null +++ b/testing.scm @@ -0,0 +1,40 @@ +;; Some simple procedures useful for implementation 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))))) + +(define (null? args) + (eq? args ())) + +; Join two lists together +(define (join l1 l2) + (if (null? l1) + l2 + (cons (car l1) (join (cdr l1) l2)))) + +; Append an arbitrary number of lists together +(define (append . lists) + (if (null? lists) + () + (if (null? (cdr lists)) + (car lists) + (join (car lists) (apply append (cdr lists)))))) + +; Macro definitions +(define-macro (let value . body ) + (list (list 'lambda (list (car value)) body)) (cdr value)) -- 2.20.1