haskeem 0.7.7 → 0.7.9
raw patch · 12 files changed
+918/−23 lines, 12 filesdep +process
Dependencies added: process
Files
- Library.hs +67/−3
- Parser.hs +5/−3
- callcc.scm +36/−0
- choice.scm +80/−0
- delcont.scm +116/−0
- deltest.scm +582/−0
- haskeem.cabal +4/−2
- haskeem.doc +7/−1
- haskeem.hs +2/−2
- haskeem_readline.hs +1/−1
- selftest.scm +12/−10
- stdlib.scm +6/−1
Library.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: library.hs,v 1.33 2009-07-04 02:48:29 uwe Exp $ -}+$Id: library.hs,v 1.37 2009-07-27 02:01:04 uwe Exp $ -} module Library (primitiveBindings, delayCounter, symbolCounter, loadFile, eqv) where@@ -38,6 +38,7 @@ import System.Time import System.CPUTime import System.Random+import System.Process import qualified Data.IntMap as DIM import Network @@ -160,6 +161,10 @@ if n < 0 then return lispTrue else return lispFalse isNegative _ = return lispFalse +isPromise :: [LispVal] -> ThrowsError LispVal+isPromise [Delay _ _ _] = return lispTrue+isPromise _ = return lispFalse+ -- The treatment of Inf and NaN is not quite according to R6RS here. they say -- (/ 1 0) causes an exception, but I can't find what happens if the parser -- sees the number 1/0. I think it ought to be Inf, or perhaps RatInf. So I'm@@ -662,6 +667,14 @@ symb2str [Symbol s] = return (String s) symb2str badArgList = genericBadArg badArgList "symbol->string" "string" 1 +str2symb :: [LispVal] -> ThrowsError LispVal+str2symb [String []] = genericBadArg [String ""] "string->symbol" "string" 1+str2symb [String s] = return (Symbol (sanitize s))+ where sanitize (c:cs) = schar isAlpha c : map (schar isAlphaNum) cs+ schar pred c =+ if (pred c) || (c `elem` specialSymbolChars) then c else '_'+str2symb badArgList = genericBadArg badArgList "string->symbol" "string" 1+ readNum :: [LispVal] -> ThrowsError LispVal readNum [String s] = readNumber s readNum badArgList = genericBadArg badArgList "string->number" "string" 1@@ -977,6 +990,7 @@ ("null?", isNull), ("port?", isPort), ("procedure?", isProcedure),+ ("promise?", isPromise), ("vector?", isVector), ("even?", lispIsEven), ("odd?", lispIsOdd),@@ -1003,6 +1017,7 @@ ("string->number", readNum), ("number->string", writeNum), ("symbol->string", symb2str),+ ("string->symbol", str2symb), ("char-alphabetic?", charIs isAlpha), ("char-numeric?", charIs isDigit), ("char-oct-digit?", charIs isOctDigit),@@ -1143,7 +1158,7 @@ lispPutStr :: [LispVal] -> IOThrowsError LispVal lispPutStr [] = return lispFalse lispPutStr ((Port port):rest) =- mapM outStr rest >> return lispTrue+ mapM_ outStr rest >> return lispTrue where outStr (String s) = doIOAction (hPutStr port s) dropToBool allErrs outStr (Char c) = doIOAction (hPutChar port c) dropToBool allErrs outStr notS = genericIOBadArg [notS] "write-string" "string" 1@@ -1512,6 +1527,52 @@ lispSetNoBuf badArgList = genericIOBadArg badArgList "set-no-buffering!" "port" 1 +-- Old version that was just one argument, no optional working directory+-- lispRunCmd :: [LispVal] -> IOThrowsError LispVal+-- lispRunCmd [String cmd] =+-- doIOAction (system cmd) getStatus allErrs+-- where getStatus (ExitSuccess) = IntNumber 0+-- getStatus (ExitFailure n) = IntNumber (fromIntegral n)+-- lispRunCmd badArgList =+-- genericIOBadArg badArgList "run-command" "command" 1++lispRunCmd :: [LispVal] -> IOThrowsError LispVal+lispRunCmd [String cmd] = lispRunCmd [String cmd, String ""]+lispRunCmd [String cmd, String dir] =+ do ret <- liftIO (try (createProcess (shell cmd)+ { cwd = if dir /= "" then Just dir else Nothing }))+ case ret of+ Left err -> throwError (Default (show err))+ Right _ -> return lispTrue+lispRunCmd badArgList =+ genericIOBadArg badArgList "run-command" "command+dir" 2++lispReadCmd :: [LispVal] -> IOThrowsError LispVal+lispReadCmd [String cmd] = lispReadCmd [String cmd, String ""]+lispReadCmd [String cmd, String dir] =+ do ret <- liftIO (try (createProcess (shell cmd)+ { cwd = if dir /= "" then Just dir else Nothing,+ std_out = CreatePipe }))+ case ret of+ Left err -> throwError (Default (show err))+ Right val -> return (Port (val2 val))+ where val2 (_, Just hout, _, _) = hout+lispReadCmd badArgList =+ genericIOBadArg badArgList "run-read-command" "command+dir" 2++lispWriteCmd :: [LispVal] -> IOThrowsError LispVal+lispWriteCmd [String cmd] = lispWriteCmd [String cmd, String ""]+lispWriteCmd [String cmd, String dir] =+ do ret <- liftIO (try (createProcess (shell cmd)+ { cwd = if dir /= "" then Just dir else Nothing,+ std_in = CreatePipe }))+ case ret of+ Left err -> throwError (Default (show err))+ Right val -> return (Port (val1 val))+ where val1 (Just hin, _, _, _) = hin+lispWriteCmd badArgList =+ genericIOBadArg badArgList "run-write-command" "command+dir" 2+ ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] ioPrimitives = [("open-input-file", makePort ReadMode), ("open-output-file", makePort WriteMode),@@ -1563,7 +1624,10 @@ ("set-no-buffering!", lispSetNoBuf), ("connect-to", lispConnectTo), ("listen-on", lispListenOn),- ("accept", lispAccept)]+ ("accept", lispAccept),+ ("run-command", lispRunCmd),+ ("run-read-command", lispReadCmd),+ ("run-write-command", lispWriteCmd)] -- A couple of predefined data values
Parser.hs view
@@ -19,9 +19,9 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: parser.hs,v 1.14 2009-06-27 20:31:52 uwe Exp $ -}+$Id: parser.hs,v 1.15 2009-07-27 02:01:04 uwe Exp $ -} -module Parser (readExpr, readExprList, readNumber) where+module Parser (readExpr, readExprList, readNumber, specialSymbolChars) where import Prelude import Data.Char import Data.Ratio@@ -56,8 +56,10 @@ -- This is not quite R6RS-compliant: R6RS allows '.' +specialSymbolChars = "!$%&*+-/:<=>?@^_~"+ symbol :: Parser Char-symbol = oneOf "!$%&*+-/:<=>?@^_~"+symbol = oneOf specialSymbolChars -- This is a small extension to R6RS
+ callcc.scm view
@@ -0,0 +1,36 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: callcc.scm,v 1.2 2009-07-11 03:59:28 uwe Exp $+; BSD3++; "poor man's" continuations: one-shot, limited lifespan, and while they+; are nestable, if you activate an outer one, any inner ones get consumed++(define (call/cc1 func)+ (let* ((sym (gensym))+ (cont (lambda (ret) (raise (cons sym ret)))))+ (guard+ (err ((and (pair? err) (eqv? sym (car err)))+ (cdr err)))+ (func cont))))++(defmacro (let/cc1 k . body)+ `(call/cc1 (lambda (,k) ,@body)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; some tests++(define (f1 n)+ (+ 10 (* 5 (/ 1 n))))++(define (f2 n)+ (+ 10 (* 5 (call/cc1+ (lambda (k)+ (/ 1 (if (zero? n)+ (k 1)+ n)))))))++(define (f3 n)+ (+ 10 (* 5 (let/cc1 k+ (/ 1 (if (zero? n)+ (k 1)+ n))))))
+ choice.scm view
@@ -0,0 +1,80 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: choice.scm,v 1.2 2009-07-11 04:32:54 uwe Exp $+; BSD3++; Non-deterministic programming: my version of (amb) with slightly different+; names, except this is more limited in that I can't call (fail) arbitrarily+; far into the future.++; Still TODO: make it work with streams as well as lists: that means that in+; the call to (,loop (cdr ,chs)) near the bottom of the macro, we might need+; to force a promise. ----> TODO^2: need to be able to query if something is+; a promise: write (promise?) primitive++; With streams, there is the issue that an infinite stream locks in all the+; previous choices, since this stuff does things in order from innermost to+; outermost: if an inner set of alternatives is infinite, it'll take infinite+; time to explore it all.++; Stack of escapers for the different choices++(define *choice-stack* (make-stack))+(define *choice-fail* (gensym))++; This function rejects the current set of choices: it pops the top+; escaper off the stack, then calls it with the failure symbol as its+; arg. The failure symbol is gensym'ed, so it can't be generated by+; the user; so there is no worry about collisions with something the+; user might want to return.++(define (bad-choice)+ (if (*choice-stack* 'empty?)+ (raise "All out of choices!")+ ((*choice-stack* 'pop) *choice-fail*)))++; This macro does the binding of the variable sym to one of the choices given,+; then executes the body. If the body calls (bad-choice), this loops to the+; next choice. If the current set of choices is exhausted, the next-lower+; choice gets reset, and so on, until we run out of choices, in which case+; the (bad-choice) function raises an(other) exception.++(defmacro (let-choice sym choices . body)+ (let ((ret (gensym))+ (cont (gensym))+ (chs (gensym))+ (loop (gensym)))+ `(letrec* ((,loop (lambda (,chs)+ (if (null? ,chs)+ (bad-choice)+ (let* ((,sym (car ,chs))+ (,ret (let/cc1 ,cont+ (*choice-stack* 'push ,cont)+ ,@body)))+ (if (eqv? ,ret *choice-fail*)+ (,loop (cdr ,chs))+ (begin (*choice-stack* 'pop)+ ,ret)))))))+ (,loop ,choices))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; Some simple examples++(define (require pred?) (if (not pred?) (bad-choice)))++(define (parlor-trick n)+ (let-choice j '(1 2 3 4 5)+ (let-choice i '(1 2 3 4 5)+ (require (= (+ i j) n))+ (list i j))))++(display (parlor-trick 4))+(newline)++(display (parlor-trick 6))+(newline)++(display (parlor-trick 10))+(newline)++(display (parlor-trick 11))+(newline)
+ delcont.scm view
@@ -0,0 +1,116 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: delcont.scm,v 1.14 2009-08-02 03:18:24 uwe Exp $+; BSD3++; Delimited continuations: these look simpler than call/cc, just a fairly+; simple code transformation. This code implements that code transformation,+; however it's not quite full-strength: in real code, the (shift) could be+; hidden inside a function, and in that case this version would not work. But+; for reset/shift that's all visible in one s-expr, I think this does pretty+; much the right thing.++; From CC Shan, "Shift to Control"++; M[(reset V)] -> M[V]++; M[(reset C [(shift f E)])] -> M[(reset E')]+; where E' = E{f -> (lambda (x) (reset C[x]))}++; M[(reset C [(control f E)])] -> M[(reset E')]+; where E' = E{f -> (lambda (x) C[x])}++; M[(reset C [(shift0 f E)])] -> M[E']+; where E' = E{f -> (lambda (x) (reset C[x]))}++; M[(reset C [(control0 f E)])] -> M[E']+; where E' = E{f -> (lambda (x) C[x])}++; TODO: the multiple-expressions handling in reset and int-s/c is+; seriously hacky: reset just wraps its args in a '(begin ...) if+; there are multiple args... gotta be a better way to do that?+; Still, this works and allows testing.++(define *delcont-list* '())++(defmacro (reset . expr)+ (letrec* ((id (gensym))+ (ret (gensym))+ (err (gensym))+ (flag #f)+ (elist (cond ((null? expr) '())+ ((null? (cdr expr)) (car expr))+ (else (cons 'begin expr))))+ (r-aux (lambda (ex)+ (cond ((not (list? ex)) ex)+ ((null? ex) ex)+ ((or (eqv? 'shift (car ex))+ (eqv? 'shift0 (car ex))+ (eqv? 'control (car ex))+ (eqv? 'control0 (car ex)))+ (let ((f1 (or (eqv? 'shift (car ex))+ (eqv? 'shift0 (car ex))))+ (f2 (or (eqv? 'shift (car ex))+ (eqv? 'control (car ex)))))+ (set! flag #t)+ (if (and (> (length ex) 2)+ (symbol? (cadr ex)))+ (append (list 'int-s/c id (gensym) f1 f2)+ (r-aux (cdr ex)))+ (raise+ "malformed shift/control expression!" ex))))+ ((eqv? 'int-s/c (car ex))+ (set! flag #t)+ (append (list 'int-s/c id) (cddr ex)))+ (else (map r-aux ex)))))+ (ex (r-aux elist)))+ (if flag+ (begin+ (set! *delcont-list* (cons ex *delcont-list*))+ `(let ((,ret (guard+ (,err ((and (pair? ,err) (eqv? ',id (car ,err)))+ (cadr ,err)))+ ,ex)))+ (set! *delcont-list* (cdr *delcont-list*))+ ,ret))+ elist)))++(defmacro (int-s/c mark id f1 f2 name . expr)+ (letrec* ((var (gensym))+ (s-aux (lambda (ex)+ (cond ((not (list? ex)) ex)+ ((null? ex) ex)+ ((eqv? 'int-s/c (car ex))+ (if (eqv? id (caddr ex))+ var+ ex))+ (else (map s-aux ex)))))+ (subst-expr (lambda (ex)+ (let ((body (s-aux ex)))+ (if f1+ `(lambda (,var) (reset ,body))+ `(lambda (,var) ,body)))))+ (lam-ex (subst-expr (car *delcont-list*))))+ (if f2+ `(raise ',mark (let ((,name ,lam-ex)) (reset ,@expr)))+ `(raise ',mark (let ((,name ,lam-ex)) ,@expr)))))++; aliases -- in this macro-based approach, they should be just sugar++(define reset0 reset)+(define prompt reset)+(define prompt0 reset)++; stupid-catchers++(defmacro (shift sym expr)+ (raise "oops, naked delcont form" 'shift sym expr))++(defmacro (shift0 sym expr)+ (raise "oops, naked delcont form" 'shift0 sym expr))++(defmacro (control sym expr)+ (raise "oops, naked delcont form" 'control sym expr))++(defmacro (control0 sym expr)+ (raise "oops, naked delcont form" 'control0 sym expr))+
+ deltest.scm view
@@ -0,0 +1,582 @@+; (load "delcont.scm")++(defmacro (sandbox . expr)+ (let ((err (gensym)))+ `(guard+ (,err ((begin (write-string "caught exception '")+ (display ,err)+ (write-string "'\n")+ #t)))+ ,@expr)))++; for mzscheme, replace the above definition of sandbox with+; (define (sandbox . expr) #t)+; it won't catch exceptions, but then mzscheme doesn't produce+; any, except for the intentional syntax error at the end++(write-string "all answers are checked against mzscheme\n")++(write-string "examples from community.schemewiki.org\n")++(write-string "should be 6\t\t")+(display (+ 1 (reset (+ 2 3))))+(newline)++(write-string "should be (1 2)\t\t")+(display (cons 1 (reset (cons 2 '()))))+(newline)++(write-string "should be 4\t\t")+(display (+ 1 (reset (+ 2 (shift k 3)))))+(newline)++(write-string "should be (1 3)\t\t")+(display (cons 1 (reset (cons 2 (shift k (cons 3 '()))))))+(newline)++(write-string "should be 10\t\t")+(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 4)))))))+(newline)++(write-string "should be 14\t\t")+(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 5) (k 1)))))))+(newline)++(write-string "should be (1 3 2 4)\t")+(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (cons 4 '()))))))))+(newline)++(write-string "should be (1 3 2 2 4)\t")+(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (k (cons 4 '())))))))))+(newline)++(write-string "multiple shifts\n")++(write-string "should be 2\t\t")+(reset (display (begin (shift k1 (k1 1)) (shift k2 (k2 2)))))+(newline)++; haskeem fails this -- restart issue+(write-string "should be 12\t\t")+(reset (begin (display (shift k1 (k1 1))) (display (shift k2 (k2 2)))))+(newline)++(write-string "should be 12\t\t")+(reset (display (shift k1 (k1 1))) (display (shift k2 (k2 2))))+(newline)++(write-string "should be 134234\t")+(reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))+ (shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))))+(newline)++(write-string "should be 134234\t")+(reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))+ (shift0 k2 (k2 (display 3)) (k2 (display 4)))))+(newline)++(write-string "should be 134234\t")+(reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))+ (shift0 k2 (k2 (display 3)) (k2 (display 4))))+(newline)++(write-string "should be 13564562356456\n\t ")+(reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))+ (shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))+ (shift0 k3 (begin (k3 (display 5)) (k3 (display 6))))))+(write-string "\n\t ")+(reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))+ (shift0 k2 (k2 (display 3)) (k2 (display 4)))+ (shift0 k3 (k3 (display 5)) (k3 (display 6)))))+(write-string "\n\t ")+(reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))+ (shift0 k2 (k2 (display 3)) (k2 (display 4)))+ (shift0 k3 (k3 (display 5)) (k3 (display 6))))+(newline)++(write-string "should be 57\t\t")+(display (+ 1 (reset (+ 2 (shift k1 (+ 3+ (k1 5)+ (k1 1)+ (reset (* 10 (shift k2 (+ 3 (k2 4)))))+ ))))))+(newline)++(write-string "should be 59\t\t")+(display (+ 1 (reset (+ 2 (shift k1 (+ 3+ (k1 5)+ (k1 1)+ (reset (* 10 (shift k2 (+ (k1 3)+ (k2 4)))))+ ))))))+(newline)++; haskeem fails the following nine -- restart issue++(write-string "should be 1 3 2\t\t")+(reset (begin (write-string "1 ")+ (shift c (begin (c 'ignore)+ (write-string "2 ")))+ (write-string "3 ")))+(newline)+(write-string "should be 1 3 2\t\t")+(reset (begin (write-string "1 ")+ (shift c (c 'ignore) (write-string "2 "))+ (write-string "3 ")))+(newline)+(write-string "should be 1 3 2\t\t")+(reset (write-string "1 ")+ (shift c (c 'ignore) (write-string "2 "))+ (write-string "3 "))+(newline)++(write-string "should be 1 2 3\t\t")+(reset (begin (write-string "1 ")+ (shift c (begin (write-string "2 ")+ (c 'ignore)))+ (write-string "3 ")))+(newline)+(write-string "should be 1 2 3\t\t")+(reset (begin (write-string "1 ")+ (shift c (write-string "2 ") (c 'ignore))+ (write-string "3 ")))+(newline)+(write-string "should be 1 2 3\t\t")+(reset (write-string "1 ")+ (shift c (write-string "2 ") (c 'ignore))+ (write-string "3 "))+(newline)++(write-string "should be 1 3 2 3\t")+(reset (begin (write-string "1 ")+ (shift c (begin (c 'ignore)+ (write-string "2 ")+ (c 'ignore)))+ (write-string "3 ")))+(newline)+(write-string "should be 1 3 2 3\t")+(reset (begin (write-string "1 ")+ (shift c (c 'ignore) (write-string "2 ") (c 'ignore))+ (write-string "3 ")))+(newline)+(write-string "should be 1 3 2 3\t")+(reset (write-string "1 ")+ (shift c (c 'ignore) (write-string "2 ") (c 'ignore))+ (write-string "3 "))+(newline)++(write-string "from Shan, \"Shift to Control\"\n")++(write-string "should be (a)\t\t")+(display (reset (cons 'a (reset (shift f (shift g '()))))))+(newline)++(write-string "should be ()\t\t")+(display (reset0 (cons 'a (reset0 (shift0 f (shift0 g '()))))))+(newline)++(write-string "should be (a)\t\t")+(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))+(newline)++(write-string "should be ()\t\t")+(display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))+(newline)++; Shan sez this is an infinite loop... Kiselyov turns this into a printing+; loop by adding (display) somewhere, have to see if I can replicate that.+; I dunno if the name has to be 'f' in both control parts++;(prompt (begin (control f (begin (f 0) (f 0)))+; (control f (begin (f 0) (f 0)))))++;;;(write-string "should be 132342344234442344442344444234444442344...\n\t ")+;;; with reset2 it /is/ an infinite loop, just not the desired one...+;;; it produces 1313131313... instead+;;; I think this is actually the same partially-evaluated-thunk issue+;;; as with the other tests which are failing+;;;(prompt (begin (control f (begin (f (display 1)) (f (display 2))))+;;; (control f (begin (f (display 3)) (f (display 4))))))+;;;(newline)++(write-string "should be (a)\t\t")+(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))+(newline)++(write-string "should be (a)\t\t")+(display (reset0 (let ((y (shift0 f (cons 'a (f '()))))) (shift0 g y))))+(newline)++(write-string "should be ()\t\t")+(display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))+(newline)++(write-string "should be ()\t\t")+(display+ (reset (prompt0 (let ((y (control0 f (cons 'a (f '()))))) (control0 g y)))))+(newline)++(write-string "should be (a b)\t\t")+(display+ (reset+ (reset (cons 'a (reset+ (let ((y (shift f (shift g (cons 'b (f '()))))))+ (shift h y)))))))+(newline)++(write-string "should be (a)\t\t")+(display+ (prompt+ (prompt (cons 'a (prompt+ (let ((y (control f (control g (cons 'b (f '()))))))+ (control h y)))))))+(newline)++(write-string "should be (b)\t\t")+(display+ (reset0+ (reset0 (cons 'a (reset0+ (let ((y (shift0 f (shift0 g (cons 'b (f '()))))))+ (shift0 h y)))))))+(newline)++; haskeem fails this -- UNKNOWN ISSUE! TODO: investigate!++(write-string "should be ()\t\t")+(display+ (prompt0+ (prompt0 (cons 'a (prompt0+ (let ((y (control0 f (control0 g (cons 'b (f '()))))))+ (control0 h y)))))))+(newline)++(write-string "two-armed tests\n")+(write-string "test 1: non-trivial shift only in false arm of if\n")+(define (doit1 flag)+ (if flag+ (write-string "should be (1 3)\t\t")+ (write-string "should be (1 4 2 5)\t"))+ (display+ (cons 1 (reset (cons 2 (if flag+ (shift k1 (cons 3 '()))+ (shift k2 (cons 4 (k2 (cons 5 '())))))))))+ (newline))++(doit1 #f)+(doit1 #t)++(write-string "test 2: reverse of previous\n")+(define (doit2 flag)+ (if flag+ (write-string "should be (1 4 2 5)\t")+ (write-string "should be (1 3)\t\t"))+ (display+ (cons 1 (reset (cons 2 (if flag+ (shift k2 (cons 4 (k2 (cons 5 '()))))+ (shift k1 (cons 3 '())))))))+ (newline))++(doit2 #f)+(doit2 #t)++(write-string "test 3: wrong? expansion of test 1\n")++(define (doit3 flag)+ (write-string "should be (1 4 3)\t") ; independent of flag+ (display+ (cons 1+ (let ((k2 (lambda (v2)+ (let ((k1 (lambda (v1)+ (reset (cons 2 (if flag v1 v2))))))+ (cons 3 '()))+ )))+ (reset (cons 4 (k2 (cons 5 '())))))))+ (newline))++(doit3 #f)+(doit3 #t)++(write-string "test 4: expansion of test 2\n")+(define (doit4 flag)+ (if flag+ (write-string "should be (1 4 2 3)\t")+ (write-string "should be (1 4 2 5)\t"))+ (display+ (cons 1+ (let ((k2 (lambda (v2)+ (reset (cons 2 (if flag (cons 3 '()) v2))))))+ (reset (cons 4 (k2 (cons 5 '())))))+ ))+ (newline))++(doit4 #f)+(doit4 #t)++(write-string "test 5: modified version, with (shift) in both arms of (if)\n")+(define (doit5 flag)+ (if flag+ (write-string "should be (1 3 2 4)\t")+ (write-string "should be (1 5 2 6)\t"))+ (display+ (cons 1+ (reset (cons 2 (if flag+ (shift k1 (cons 3 (k1 (cons 4 '()))))+ (shift k2 (cons 5 (k2 (cons 6 '())))))))))+ (newline))++(doit5 #f)+(doit5 #t)++; This one seems to be right either way... had to lift the (if flag)+; outside the (reset), which seems both intuitive and counter-intuitive.+; :-/++(write-string+ "test 6: modified version of test 5, with (if) lifted out of (reset)\n")++(define (doit6 flag)+ (if flag+ (write-string "should be (1 3 2 4)\t")+ (write-string "should be (1 5 2 6)\t"))+ (display+ (cons 1+ (if flag+ (reset (cons 2 (shift k1 (cons 3 (k1 (cons 4 '()))))))+ (reset (cons 2 (shift k2 (cons 5 (k2 (cons 6 '())))))))))+ (newline))++(doit6 #f)+(doit6 #t)++(write-string "examples from Queinnec, augmented to test all versions\n")++(write-string "prompt/control examples\n")+(write-string "should be 3\t\t")+(display (prompt (* 2 (control f 3))))+(newline)++(write-string "should be 30\t\t")+(display (prompt (* 2 (control f (* 5 (f 3))))))+(newline)++(write-string "should be 12\t\t")+(display (prompt (* 2 (control f (f (f 3))))))+(newline)++(write-string "should be 6\t\t")+(display ((prompt (* 2 (control f f))) 3))+(newline)++(write-string "should be 35\t\t")+(display (prompt (* 5+ (prompt (* 2+ (control f2 (* 3 (control f3 7))))))))+(newline)++; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,+; and so at the end there's an uncaught exception which however carries+; along the correct value as its payload. So I think haskeem would handle+; this correctly if there were an implicit top-level catcher++(write-string "should be 7\t\t")+(sandbox+ (display (prompt (* 5 (+ (prompt (* 2+ (control f2 (lambda ()+ (* 3 (control f3 7))))))))))+ (newline))++(write-string "should be 21\t\t")+(display (prompt (* 5+ ((lambda (x) (control f1 x))+ (* 3 (control f2 (* 2 (f2 7))))))))+(newline)++(write-string "prompt0/control0 examples\n")+(write-string "should be 3\t\t")+(display (prompt0 (* 2 (control0 f 3))))+(newline)++(write-string "should be 30\t\t")+(display (prompt0 (* 2 (control0 f (* 5 (f 3))))))+(newline)++(write-string "should be 12\t\t")+(display (prompt0 (* 2 (control0 f (f (f 3))))))+(newline)++(write-string "should be 6\t\t")+(display ((prompt0 (* 2 (control0 f f))) 3))+(newline)++(write-string "should be 7\t\t")+(display (prompt0 (* 5+ (prompt0 (* 2+ (control0 f2 (* 3 (control0 f3 7))))))))+(newline)++(write-string "should be 7\t\t")+(sandbox+ (display (prompt0 (* 5 (+ (prompt0 (* 2+ (control0 f2 (lambda ()+ (* 3 (control0 f3 7))))))))))+ (newline))++; There's something odd with this test: in mzscheme, it prints the+; result 21, then the whole rest of the test vanishes; apparently+; enough of the surrounding context is sucked up that the rest of the+; world just vanishes. If I surround this with a (reset ...), the+; test continues, but this doesn't print anything. Hmmm!++(write-string "should be 21\t\t")+(sandbox+ (display (prompt0 (* 5+ ((lambda (x) (control0 f1 x))+ (* 3 (control0 f2 (* 2 (f2 7))))))))+ (newline))++(write-string "reset/shift examples\n")+(write-string "should be 3\t\t")+(display (reset (* 2 (shift f 3))))+(newline)++(write-string "should be 30\t\t")+(display (reset (* 2 (shift f (* 5 (f 3))))))+(newline)++(write-string "should be 12\t\t")+(display (reset (* 2 (shift f (f (f 3))))))+(newline)++(write-string "should be 6\t\t")+(display ((reset (* 2 (shift f f))) 3))+(newline)++(write-string "should be 35\t\t")+(display (reset (* 5+ (reset (* 2+ (shift f2 (* 3 (shift f3 7))))))))+(newline)++; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,+; and so at the end there's an uncaught exception which however carries+; along the correct value as its payload. So I think haskeem would handle+; this correctly if there were an implicit top-level catcher++(write-string "should be 7\t\t")+(sandbox+ (display (reset (* 5 (+ (reset (* 2+ (shift f2 (lambda ()+ (* 3 (shift f3 7))))))))))+ (newline))++(write-string "should be 42\t\t")+(display (reset (* 5+ ((lambda (x) (shift f1 x))+ (* 3 (shift f2 (* 2 (f2 7))))))))+(newline)++(write-string "reset0/shift0 examples\n")+(write-string "should be 3\t\t")+(display (reset0 (* 2 (shift0 f 3))))+(newline)++(write-string "should be 30\t\t")+(display (reset0 (* 2 (shift0 f (* 5 (f 3))))))+(newline)++(write-string "should be 12\t\t")+(display (reset0 (* 2 (shift0 f (f (f 3))))))+(newline)++(write-string "should be 6\t\t")+(display ((reset0 (* 2 (shift0 f f))) 3))+(newline)++(write-string "should be 7\t\t")+(display (reset0 (* 5+ (reset0 (* 2+ (shift0 f2 (* 3 (shift0 f3 7))))))))+(newline)++(write-string "should be 7\t\t")+(sandbox+ (display (reset0 (* 5 (+ (reset0 (* 2+ (shift0 f2 (lambda ()+ (* 3 (shift0 f3 7))))))))))+ (newline))++(write-string "should be 42\t\t")+(display (reset0 (* 5+ ((lambda (x) (shift0 f1 x))+ (* 3 (shift0 f2 (* 2 (f2 7))))))))+(newline)++(write-string "something actually useful! a small table of factorials\n")++; Eventually we want to be able to use code like this:++; (defmacro (range from step to)+; (let ((f (gensym))+; (i (gensym)))+; `(shift ,f+; (do ((,i ,from (+ ,i ,step)))+; ((> ,i ,to) #f)+; (,f ,i)))))+;+; (reset (begin (display (my-fact (range 1 3 16))) (newline)))++; Just to show I've got nothing up my sleeve, here is a perfectly cromulent+; function; we could equally well use the built-in (factorial) function++(define (my-fact n)+ (if (<= n 0)+ 1+ (* n (my-fact (- n 1)))))++(define from 1)+(define to 21)+(define step 3)++(reset (display (my-fact + (shift f+ (do ((i from (+ i step)))+ ((> i to) #f)+ (write-string (number->string i))+ (write-string "! =\t")+ (f i)))))+ (newline))++; This one is specific to haskeem, because the macro reset doesn't start+; the thunk in the middle, but rather at the beginning; that makes the+; ping-pong possible++(write-string+ "These rely on the reset thunk being re-evaluated from the beginning,\n")+(write-string+ "so strictly speaking both are wrong. So I don't know what the answers\n")+(write-string+ "\"should be\"... but they look plausible\n")+(define (doit7 flag)+ (display+ (cons 1+ (reset (cons 2 (if flag+ (shift k1 (set! flag (not flag))+ (cons 3 (k1 (cons 4 '()))))+ (shift k2 (set! flag (not flag))+ (cons 5 (k2 (cons 6 '())))))))))+ (newline))++; it's hard to say if these are right... both rely on a wrong implementation+; of the thunk stuff++(doit7 #f) ; (1 5 3 2 6) -- mzscheme sez (1 5 2 6)+(doit7 #t) ; (1 3 5 2 4) -- mzscheme sez (1 3 2 4)++(write-string+ "syntax error coming up! should be an error... this'll kill mzscheme\n")++(sandbox (display (+ 1 (reset (+ 2 (shift (+ k 1) 3))))))
haskeem.cabal view
@@ -1,11 +1,13 @@ Name: haskeem-Version: 0.7.7+Version: 0.7.9 Homepage: http://www.korgwal.com/haskeem/ 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 is however starting to have a set of delimited+ continuations (implemented as macros, so not quite "native"). It has a macro system, although not R6RS hygienic macros. It is also not necessarily fully tail-recursive; so it's not industrial-strength. For playing with or learning@@ -17,7 +19,7 @@ Category: Compilers/Interpreters Executable haskeem- Build-Depends: base >= 4 && < 5, network, containers, mtl, parsec,+ Build-Depends: base >= 4 && < 5, network, containers, mtl, parsec, process, haskell98, random, old-time, unix, directory, haskeline Main-is: haskeem.hs Other-Modules: LispData
haskeem.doc view
@@ -15,7 +15,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.doc,v 1.39 2009-07-03 23:17:00 uwe Exp $+; $Id: haskeem.doc,v 1.40 2009-07-10 05:15:38 uwe Exp $ ; Input to documentation generator for haskeem. The intent is that this ; does NOT have to be globally ordered, it is possible to just add new@@ -441,3 +441,9 @@ ((function make-stack) (args . values) (return function)) ((macro fluid-let) (args (vars params) . body))++((primitive run-command) (args command) (return exit-status))+((primitive run-read-command) (args command) (return port))+((primitive run-read-command) (args command working-directory) (return port))+((primitive run-write-command) (args command) (return port))+((primitive run-write-command) (args command working-directory) (return port))
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.36 2009-07-04 19:07:00 uwe Exp $ -}+$Id: haskeem.hs,v 1.38 2009-07-27 04:46:22 uwe Exp $ -} module Main where import Prelude@@ -43,7 +43,7 @@ -- haskeem version version :: String-version = "0.7.7"+version = "0.7.9" -- 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.7.7"+version = "0.7.9" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode
selftest.scm view
@@ -15,7 +15,7 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: selftest.scm,v 1.45 2009-07-04 01:29:53 uwe Exp $+; $Id: selftest.scm,v 1.46 2009-07-19 02:36:21 uwe Exp $ (define start (epochtime)) @@ -2406,7 +2406,8 @@ (catch-exceptions (chk-run #t '(set-current-directory test-dir1))) (catch-exceptions (chk-query "test directory" '(get-current-directory))) (catch-exceptions (chk-run #t '(set-current-directory "..")))- (catch-exceptions (chk-run #t '(remove-directory test-dir1))))+ (catch-exceptions (chk-run #t '(remove-directory test-dir1)))+ (run-command (string-join-by " " "/bin/rm -rf" test-dir1))) (if (directory-exists? test-dir1) (write-string "\nSkipping file and directory I/O tests,\n"@@ -2596,25 +2597,26 @@ (chk-run 1243 '(ilog (expt 2 1243))) (define mynum 1.2345)+; If this is true, we'll see 1.235 with rounding in two places below,+; and 1.2345000000000002e0 without rounding+(define mynumtest? (< 12345 (* mynum 10000))) -(write-string "The following two tests might fail, "- "returning \"1.2345000000000002e0\" instead\n")-(chk-run "1.2345e0" '(number->string mynum))-(chk-run "1.2345e0" '(number->string mynum 10))+(chk-run (if mynumtest? "1.2345000000000002e0" "1.2345e0")+ '(number->string mynum))+(chk-run (if mynumtest? "1.2345000000000002e0" "1.2345e0")+ '(number->string mynum 10)) (chk-run "1.2345" '(number->string mynum 10 4)) (chk-run "1.23450" '(number->string mynum 10 5)) (chk-run "1.234500" '(number->string mynum 10 6)) -(write-string "This test might fail, returning \"1.235\" instead\n")-(chk-run "1.234" '(number->string mynum 10 3))+(chk-run (if mynumtest? "1.235" "1.234") '(number->string mynum 10 3)) (chk-run "1.23" '(number->string mynum 10 2)) (chk-run "1.2" '(number->string mynum 10 1)) (chk-run "1." '(number->string mynum 10 0)) (chk-run "1.2e0" '(number->string mynum 10 -1)) (chk-run "1.23e0" '(number->string mynum 10 -2)) -(write-string "This test might fail, returning \"1.235e0\" instead\n")-(chk-run "1.234e0" '(number->string mynum 10 -3))+(chk-run (if mynumtest? "1.235e0" "1.234e0") '(number->string mynum 10 -3)) (chk-run "1.2345e0" '(number->string mynum 10 -4)) (chk-run "1.2345e0" '(number->string 12345e-4 10 -4)) (chk-run "1.2345" '(number->string 12345/10000 10 4))
stdlib.scm view
@@ -111,7 +111,12 @@ (define (compose f g) (lambda args (apply f (apply g args)))) -(define fcdr (compose force cdr))+;;; (define fcdr (compose force cdr))+(define (fcdr x)+ (let ((cx (cdr x)))+ (if (promise? cx)+ (force cx)+ cx))) (define (cycle lst) (letrec ((next (lambda (cur)