haskeem 0.6.10 → 0.7.0
raw patch · 8 files changed
+159/−40 lines, 8 filesdep ~base
Dependency ranges changed: base
Files
- Evaluator.hs +32/−9
- LispData.hs +12/−3
- fibo.scm +12/−7
- haskeem.cabal +18/−17
- haskeem.hs +2/−2
- haskeem_readline.hs +1/−1
- macro-test.scm +73/−0
- stdlib.scm +9/−1
Evaluator.hs view
@@ -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)
LispData.hs view
@@ -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 = _}) =+ "<macro (" ++ (unwords args) +++ (case varargs of+ Nothing -> ""+ Just arg -> " . " ++ arg) ++ ") ...>" showVal (IOPrim _) = "<IO primitive>" showVal (Port _) = "<IO port>" showVal (Socket _) = "<IO socket>"
fibo.scm view
@@ -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))
haskeem.cabal view
@@ -1,22 +1,23 @@-Name: haskeem-Version: 0.6.10-Author: Uwe Hollerbach <uh@alumni.caltech.edu>-Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>-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 <uh@alumni.caltech.edu>+Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>+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
haskeem.hs view
@@ -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
haskeem_readline.hs view
@@ -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
+ macro-test.scm view
@@ -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")
stdlib.scm view
@@ -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