diff --git a/Evaluator.hs b/Evaluator.hs --- a/Evaluator.hs +++ b/Evaluator.hs @@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: evaluator.hs,v 1.26 2009-05-31 01:41:07 uwe Exp $ -} +$Id: evaluator.hs,v 1.27 2009-06-06 20:40:08 uwe Exp $ -} module Evaluator (evalLisp) where import Prelude @@ -83,7 +83,7 @@ doCheck rest && uniqCheck var rest doCheck _ = False --- Ditto for "define" and "lambda" params lists and dotted-lists +-- Ditto for "define", "defmacro", and "lambda" params lists and dotted-lists paramsCheck :: [LispVal] -> Bool paramsCheck [] = True @@ -125,6 +125,8 @@ apply _ (IOPrim func) args = func args apply ql (Func params varargs body closure) args = doApply False "" params varargs body closure ql args +apply ql (Macro params varargs body closure) args = + doApply False "" params varargs body closure ql args apply ql (TraceFunc name params varargs body closure) args = doApply True name params varargs body closure ql args apply _ func _ = throwError (NotFunction "apply got non-function" func) @@ -132,8 +134,13 @@ makeFunc varargs env params body = return (Func (map show params) varargs body env) makeNormalFunc = makeFunc Nothing -makeVarargs = makeFunc . Just . show +makeVarargsFunc = makeFunc . Just . show +makeMacro varargs env params body = + return (Macro (map show params) varargs body env) +makeNormalMacro = makeMacro Nothing +makeVarargsMacro = makeMacro . Just . show + isSpecialForm :: LispVal -> Bool isSpecialForm (Symbol "and") = True isSpecialForm (Symbol "apply") = True @@ -141,6 +148,7 @@ isSpecialForm (Symbol "case") = True isSpecialForm (Symbol "cond") = True isSpecialForm (Symbol "define") = True +isSpecialForm (Symbol "defmacro") = True isSpecialForm (Symbol "delay") = True isSpecialForm (Symbol "do") = True isSpecialForm (Symbol "eval") = True @@ -426,19 +434,31 @@ DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs]) then do defineVar env var (Bool False) - makeVarargs varargs env params body >>= setVar env var + makeVarargsFunc varargs env params body >>= setVar env var else errBadForm "define" [DottedList params varargs] +evalLisp env _ (List (Symbol "defmacro" : List (Symbol var : params) : body)) = + if paramsCheck params + then do defineVar env var (Bool False) + makeNormalMacro env params body >>= setVar env var + else errBadForm "defmacro" params +evalLisp env _ (List (Symbol "defmacro" : + DottedList (Symbol var : params) varargs : body)) = + if paramsCheck (params ++ [varargs]) + then do defineVar env var (Bool False) + makeVarargsMacro varargs env params body >>= setVar env var + else errBadForm "defmacro" [DottedList params varargs] + evalLisp env _ (List (Symbol "lambda" : List params : body)) = if paramsCheck params then makeNormalFunc env params body else errBadForm "lambda" params evalLisp env _ (List (Symbol "lambda" : DottedList params varargs : body)) = if paramsCheck (params ++ [varargs]) - then makeVarargs varargs env params body + then makeVarargsFunc varargs env params body else errBadForm "lambda" [DottedList params varargs] evalLisp env _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) = - makeVarargs varargs env [] body + makeVarargsFunc varargs env [] body evalLisp env ql (List [Symbol "if", pred, tcase, fcase]) = do result <- evalLisp env ql pred @@ -743,14 +763,17 @@ getPort (Port p) = p getPort _ = progError --- the generic (function : args) stuff +-- The generic (function : args) stuff; also macro expansion stuff evalLisp env ql (List (function : args)) = if isSpecialForm function then throwError (BadSpecial "bad syntax for special form" function) else do func <- evalLisp env ql function - argVals <- mapM (evalLisp env ql) args - apply ql func argVals + if isM func + then apply ql func args >>= evalLisp env ql + else mapM (evalLisp env ql) args >>= apply ql func + where isM (Macro _ _ _ _) = True + isM _ = False evalLisp _ _ badForm = throwError (BadSpecial "Unrecognized special form" badForm) diff --git a/LispData.hs b/LispData.hs --- a/LispData.hs +++ b/LispData.hs @@ -19,12 +19,12 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: lispdata.hs,v 1.11 2009-05-31 01:41:08 uwe Exp $ -} +$Id: lispdata.hs,v 1.12 2009-06-06 20:40:09 uwe Exp $ -} module LispData (LispVal(Symbol, Bool, Char, Delay, DottedList, IntNumber, RatNumber, - FltNumber, Func, IOPrim, List, Port, Prim, Socket, String, - TraceFunc, Vector), + FltNumber, Func, IOPrim, List, Macro, Port, Prim, Socket, + String, TraceFunc, Vector), LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction, UnboundVar, Default, OutOfRange, VectorBounds, UserException), ThrowsError, Env, IOThrowsError, liftThrows, @@ -82,6 +82,10 @@ vararg :: (Maybe String), body :: [LispVal], closure :: Env} + | Macro {params :: [String], + vararg :: (Maybe String), + body :: [LispVal], + closure :: Env} | Delay {obj :: LispVal, closure :: Env, tag :: String} @@ -125,6 +129,11 @@ (case varargs of Nothing -> "" Just arg -> " . " ++ arg) ++ ") ...)" +showVal (Macro {params = args, vararg = varargs, body = _, closure = _}) = + " "" + Just arg -> " . " ++ arg) ++ ") ...>" showVal (IOPrim _) = "" showVal (Port _) = "" showVal (Socket _) = "" diff --git a/fibo.scm b/fibo.scm --- a/fibo.scm +++ b/fibo.scm @@ -1,5 +1,6 @@ ; Fibonacci routines, good & bad: these also show how to use trace -; $Id: fibo.scm,v 1.2 2009-05-26 04:22:10 uwe Exp $ +; AAAAAND a super-spiffy memoize function, slicker'n snot onna log! +; $Id: fibo.scm,v 1.4 2009-06-04 06:20:58 uwe Exp $ ; efficient Fibonacci function: use accumulator to calculate in linear time @@ -31,8 +32,8 @@ (else (+ (memo-fibo (- n 1)) (memo-fibo (- n 2)))))) (trace memo-fibo #t) -; cache access: a cache is a list of dotted-pairs, with the car of -; each pair being the argument, and the cdr being the function value. +; cache access: a cache is a list of dotted-pairs, with the car of each +; pair being the argument (list), and the cdr being the function value. ; return (#t . fval) if found, (#f . #f) if not found (define (get-cache cache in) @@ -41,16 +42,20 @@ (else (get-cache (cdr cache) in)))) ; return a memoized version of the given function +; this memoize function is fully variadic, so it can be applied to a +; function of any number of arguments +; the limiting factor in using this is that the cache is a simple list, +; so searching it is linear-time (define (memoize fn) (if (procedure? fn) (let ((cache ())) - (lambda (arg) - (let ((cval (get-cache cache arg))) + (lambda args + (let ((cval (get-cache cache args))) (if (car cval) (cdr cval) - (let ((nval (fn arg))) - (set! cache (cons (cons arg nval) cache)) + (let ((nval (apply fn args))) + (set! cache (cons (cons args nval) cache)) nval))))) fn)) diff --git a/haskeem.cabal b/haskeem.cabal --- a/haskeem.cabal +++ b/haskeem.cabal @@ -1,22 +1,23 @@ -Name: haskeem -Version: 0.6.10 -Author: Uwe Hollerbach -Maintainer: Uwe Hollerbach -Synopsis: A small scheme interpreter -Description: This is a moderately complete small scheme interpreter. - It implements most of R6RS, with the exception of call/cc - and a macro system. It is also not necessarily fully - tail-recursive; so it's not industrial-strength. For - playing with or learning scheme, it should be pretty good. -License: GPL -License-File: LICENSE -Cabal-Version: >= 1.2 -Build-Type: Simple -Category: Compilers/Interpreters +Name: haskeem +Version: 0.7.0 +Author: Uwe Hollerbach +Maintainer: Uwe Hollerbach +Synopsis: A small scheme interpreter +Description: This is a moderately complete small scheme interpreter. + It implements most of R6RS, with the exception of call/cc. + It has a macro system, but not R6RS hygienic macros. + It is also not necessarily fully tail-recursive; so it's + not industrial-strength. For playing with or learning + scheme, it should be pretty good. +License: GPL +License-File: LICENSE +Cabal-Version: >= 1.2 +Build-Type: Simple +Category: Compilers/Interpreters Executable haskeem - Build-Depends: base >= 4, network, containers, mtl, parsec, haskell98, - random, old-time, unix, directory, haskeline + Build-Depends: base >= 4 && < 5, network, containers, mtl, parsec, + haskell98, random, old-time, unix, directory, haskeline Main-is: haskeem.hs Other-Modules: LispData Parser diff --git a/haskeem.hs b/haskeem.hs --- a/haskeem.hs +++ b/haskeem.hs @@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: haskeem.hs,v 1.26 2009-05-31 01:41:07 uwe Exp $ -} +$Id: haskeem.hs,v 1.27 2009-06-06 20:40:08 uwe Exp $ -} module Main where import Prelude @@ -43,7 +43,7 @@ -- haskeem version version :: String -version = "0.6.10" +version = "0.7.0" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode diff --git a/haskeem_readline.hs b/haskeem_readline.hs --- a/haskeem_readline.hs +++ b/haskeem_readline.hs @@ -43,7 +43,7 @@ -- haskeem version version :: String -version = "0.6.9" +version = "0.7.0" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode diff --git a/macro-test.scm b/macro-test.scm new file mode 100644 --- /dev/null +++ b/macro-test.scm @@ -0,0 +1,73 @@ +(write-string "################ numeric-if test\n") + +; This tests how many times everything gets evaluated +(define probe 0) + +(define neg-action (lambda () (set! probe (+ probe 1)) "negative!")) +(define zero-action (lambda () (set! probe (+ probe 10)) "zero!")) +(define pos-action (lambda () (set! probe (+ probe 100)) "positive!")) + +; The value returned from this determines which of the three branches is chosen +(define test-value (lambda () (set! probe (+ probe 1000)) -1)) + +(define numeric-if-tmp "foo") + +; This version is careful to evaluate tval only once +(defmacro (numeric-if-1 tval ifn ifz ifp) + `(let ((numeric-if-tmp ,tval)) + (display numeric-if-tmp) + (newline) + (if (number? numeric-if-tmp) + (if (negative? numeric-if-tmp) + ,ifn + (if (positive? numeric-if-tmp) + ,ifp + ,ifz)) + (raise "error: non-numeric test value passed to numeric-if")))) + +; This version might evaluate tval two or three times +(defmacro (numeric-if-2 tval ifn ifz ifp) + `(if (number? ,tval) + (if (negative? ,tval) + ,ifn + (if (positive? ,tval) + ,ifp + ,ifz)) + (raise "error: non-numeric test value passed to numeric-if"))) + +; A function version of numeric-if would evaluate each argument precisely once, +; so that after the test the value of probe would be 1111 + +(display numeric-if-tmp) +(newline) +(write-string "before: probe is " (number->string probe) #\newline) +(define ret + (guard + (err ((begin (write-string "exception is '") + (display err) + (write-string "'\n") + #t) err)) + (numeric-if-2 (test-value) + (neg-action) + (zero-action) + (pos-action)))) +(write-string "after: probe is " (number->string probe) #\newline) +(write-string "result returned: ") +(display ret) +(newline) +(display numeric-if-tmp) +(newline) + +(write-string "################ assertion test\n") +(defmacro (assert some-cond) + `(when (not ,some-cond) + (write-string "assertion failure: ") + (display ',some-cond) + (newline))) + +(define x "foo") +(display x) +(newline) +(assert (eqv? x "bar")) + +(write-string "################ th-th-that's all, folks!\n") diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -19,7 +19,7 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: stdlib.scm,v 1.33 2009-03-28 20:34:38 uwe Exp $ +; $Id: stdlib.scm,v 1.34 2009-06-04 06:20:58 uwe Exp $ ; The haskeem standard library @@ -51,6 +51,14 @@ (define (cddadr pair) (cdr (cdr (car (cdr pair))))) (define (cdddar pair) (cdr (cdr (cdr (car pair))))) (define (cddddr pair) (cdr (cdr (cdr (cdr pair))))) + +(define (nth n lst) + (cond ((or (not (integer? n)) + (negative? n) + (null? lst)) + (raise "bad input to nth")) + ((zero? n) (car lst)) + (else (nth (- n 1) (cdr lst))))) ; TODO: This is a hack: it looks (and, indeed, it is) quite idiotic, ; but it's the right thing: "eval" is currently a special form in