haskeem 0.7.4 → 0.7.5

raw patch · 10 files changed

+370/−26 lines, 10 files

Files

• Evaluator.hs +10/−2
• LispData.hs +2/−2
• cpm.scm +113/−0
• haskeem.cabal +2/−1
• haskeem.doc +57/−1
• haskeem.hs +2/−2
• haskeem_readline.hs +1/−1
• heap.scm +166/−0
• regexp.scm +13/−13
• set.scm +4/−4

@@ -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.31 2009-06-27 21:51:29 uwe Exp $ -}+$Id: evaluator.hs,v 1.32 2009-06-29 03:59:13 uwe Exp $ -}  module Evaluator (evalLisp) where import Prelude@@ -710,6 +710,9 @@ -- (trace 'function #t), but tracing sub-functions needs a special -- form, because it needs access to the current environment rather than -- the top-level environment.+-- We require the literal form '(trace name #t/f), rather than some+-- expression which evaluates to the symbol to trace, because we want+-- to have a name: var is what gets used. Consider relaxing this?  evalLisp env ql (List [Symbol "trace", Symbol var, sw]) =   if isSpecialForm (Symbol var)@@ -756,13 +759,16 @@         getPort _ = progError  -- The generic (function : args) stuff; also macro expansion stuff+-- For macro expansion, we evaluate once to get syntax back from the+-- macro, that's the "evalLisp env ql function", but then we change+-- the environment to evaluate that syntax in the caller's environment.  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              if isM func-                then apply ql func args >>=+                then apply ql (chEnv func env) args >>=                      prtTrace (isT func) >>=                      evalLisp env ql                 else mapM (evalLisp env ql) args >>= apply ql func@@ -770,6 +776,8 @@         isM _ = False         isT (Func _ _ _ _ (Just _) _) = True         isT _ = False+        chEnv (Func pars vars bod envo name mac) envn =+          Func pars vars bod envn name mac         prtTrace trace vals =           if trace              then remark ("   ->  " ++ (show vals)) >> return vals

@@ -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: lispdata.hs,v 1.14 2009-06-27 21:51:29 uwe Exp $ -}+$Id: lispdata.hs,v 1.15 2009-06-29 00:23:01 uwe Exp $ -}  module LispData     (LispVal(Symbol, Boolean, Char, Delay, DottedList, IntNumber,@@ -126,7 +126,7 @@               (case varargs of                     Nothing -> ""                     Just arg -> " . " ++ arg) ++ ") " ++-              (unwords (map showVal bd)) ++ lclose+              "..." ++ lclose   in case nm of           Nothing -> inner           Just val -> "(" ++ val ++ " . " ++ inner ++ ")"

@@ -0,0 +1,113 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: cpm.scm,v 1.1 2009-06-29 03:59:41 uwe Exp $+; BSD3++; Continuation-passing macros in the style of "On Lisp" by Paul Graham;+; but the syntax is scheme (well, scheme - call/cc) and any mistakes or+; misunderstandings are mine, mine, all mine!++; Define the continuation variable which gets passed around (and overridden),+; initially just set to the identity, the default top-level continuation.++(define *cont* (lambda (val) val))++; Define the CPS analog of (lambda): the same as (lambda), just with the+; extra continuation argument glued into place.++(defmacro (=lambda params . body)+  (if (symbol? params)+      `(lambda (*cont* . ,params) ,@body)+      `(lambda (*cont* ,@params) ,@body)))++; Define the CPS analog of (apply): the same as apply, just add in the extra+; continuation argument++(defmacro (=apply fn . args)+  `(apply ,fn *cont* ,@args))++; Define the "return a value" macro: instead of actually returning, this+; applies the current continuation to the specified value. I'm not bothering+; with multiple-value return right now, since haskeem only does one value+; at a time.++(defmacro (=return val)+  `(*cont* ,val))++; Define the CPS analog of (define): define a macro that looks like+; the function without the continuation argument, and define the+; function using a generated symbol with the continuation argument.++; This only does the (define (foo args) body) version so far, check+; for (symbol? formals) to capture the (define foo <stuff>) version;+; or just disallow that usage: it's captured above by the =lambda+; stuff.++; NOTE: if it's desirable to (trace) the function, it has to be done+; here inside the (=define) macro, inside each (begin) after the+; (define (,ifn ...) ...). Otherwise, it's tricky to get at it.++(defmacro (=define formals . body)+  (let ((ifn (new-symbol))+	(fn (car formals))+	(args (cdr formals)))+    (if (symbol? args)+	`(begin (defmacro ,formals (,ifn *cont* . ,args))+		(define (,ifn *cont* . ,args) ,@body))+	`(begin (defmacro ,formals (,ifn *cont* ,@args))+		(define (,ifn *cont* ,@args) ,@body)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; Test stuff++; Expect to see this print "5"++(define foo (=lambda (x) (=return (+ 1 x))))+(display (foo *cont* 4))+(newline)++; This should print "10"++(let ((*cont* (lambda (x) (* 2 x))))+  (display (foo *cont* 4))+  (newline))++; This should print "14": the function says to add 10 to the value passed+; in, and the current continuation, which is the default identity, is then+; applied to that value: 4 + 10 -> identity -> 14++(=define (bar x) (=return (+ 10 x)))+(display (bar 4))+(newline)++; Expect to see this print... "15"? the function again adds 10 to what's+; passed in, but here the current continuation has been re-jiggered to+; add 1 to what it receives: 4 + 10 -> 14 -> (+1) -> 15.+; In++(let ((*cont* (lambda (x) (+ 1 x))))+  (display (bar 4))+  (newline))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; explicit CPS conversion of fibonacci function:++(define (fib-no n)+  (if (< n 2)+      1+      (+ (fib-no (- n 1))+	 (fib-no (- n 2)))))++; becomes++(define (fib-cps k n)+  (if (< n 2)+      (k 1)+      (fib-cps (lambda (fib-of-n-1)+		 (fib-cps (lambda (fib-of-n-2)+			    (k (+ fib-of-n-1 fib-of-n-2)))+			  (- n 2)))+	       (- n 1))))++; and a wrapper which just passes in the identity function as the continuation++(define (fib-yes n) (fib-cps (lambda (x) x) n))

@@ -1,5 +1,6 @@ Name:             haskeem-Version:          0.7.4+Version:          0.7.5+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

@@ -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.35 2009-06-20 03:09:42 uwe Exp $+; $Id: haskeem.doc,v 1.36 2009-06-29 00:25:51 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@@ -384,3 +384,59 @@  ((data args)) ((function cycle) (args list) (return stream))++((function heap-new) (args pred? size) (return vector))+((function heap-insert) (args vector obj) (return vector))+((function heap-remove) (args vector) (return obj vector))+((macro heap-insert!) (args vector obj) (return vector))+((macro heap-remove!) (args vector) (return obj vector))++((function set-new) (args) (return set))+((function intset-new) (args) (return intset))+((function bitset-new) (args) (return bitset))++((function set-member?) (args set element) (return bool))+((function intset-member?) (args intset element) (return bool))+((function bitset-member?) (args bitset element) (return bool))++((function set-empty?) (args set) (return bool))+((function intset-empty?) (args intset) (return bool))+((function bitset-empty?) (args bitset) (return bool))++((function set-add) (args set element) (return set))+((function intset-add) (args intset element) (return intset))+((function bitset-add) (args bitset element) (return bitset))++((function set-remove) (args set element) (return set))+((function intset-remove) (args intset element) (return intset))+((function bitset-remove) (args bitset element) (return bitset))++((function set-remove-dups) (args set) (return set))+((function intset-remove-dups) (args intset) (return intset))+((function bitset-remove-dups) (args bitset) (return bitset))++((function set-or) (args set set) (return set))+((function intset-or) (args intset intset) (return intset))+((function bitset-or) (args bitset bitset) (return bitset))++((function set-andnot) (args set set) (return set))+((function intset-andnot) (args intset intset) (return intset))+((function bitset-andnot) (args bitset bitset) (return bitset))++((function set-xor) (args set set) (return set))+((function intset-xor) (args intset intset) (return intset))+((function bitset-xor) (args bitset bitset) (return bitset))++((function set-and) (args set set) (return set))+((function intset-and) (args intset intset) (return intset))+((function bitset-and) (args bitset bitset) (return bitset))++((function set-equal?) (args set set) (return bool))+((function intset-equal?) (args intset intset) (return bool))+((function bitset-equal?) (args bitset bitset) (return bool))++((function bitset->list) (args bitset) (return list))++((function set-for-each) (args set fn))+((function intset-for-each) (args intset fn))+((function bitset-for-each) (args bitset fn))

@@ -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.33 2009-06-27 20:31:51 uwe Exp $ -}+$Id: haskeem.hs,v 1.34 2009-06-29 04:21:36 uwe Exp $ -}  module Main where import Prelude@@ -43,7 +43,7 @@ -- haskeem version  version :: String-version = "0.7.4"+version = "0.7.5"  -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode

@@ -43,7 +43,7 @@ -- haskeem version  version :: String-version = "0.7.0"+version = "0.7.5"  -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode

@@ -0,0 +1,166 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: heap.scm,v 1.2 2009-06-29 00:24:24 uwe Exp $+; BSD3++; Priority queues implemented as heaps++; What's a heap? It's a vector containing another vector:+;+;	#(pred? cur-size #(array))+;+; where pred? is a predicate used to maintain the heap structure, cur-size+; is the number of items currently in the heap, and array is the actual+; heap.++; Create a new heap which will use the given predicate for comparisons, and+; set it to initially have the given size. Vectors can be resized, so it's+; not a big deal to get the size wrong.++(define (heap-new pred? size)+  (let ((h (make-vector 3))+	(s (max size 1)))+    (vector-set! h 0 pred?)+    (vector-set! h 1 0)+    (vector-set! h 2 (make-vector s))))++; Insert an item into a heap, maintaining the heap condition;+; Return the modified heap++(define (heap-insert heap item)+  (let* ((pred? (vector-ref heap 0))+	 (k (vector-ref heap 1))+	 (a (vector-ref heap 2))+	 (n (vector-length a))+	 (kp #f)+	 (parent (lambda (j) (quotient (- j 1) 2))))+; make sure there's space for insertion+    (when (= k n)+	  (set! n (* n 2))+	  (vector-resize! a n))+; insert item at end of heap+    (vector-set! a k item)+    (vector-set! heap 1 (+ k 1))+; restore heap condition+    (do ((kp (parent k) (parent k)))+	((or (zero? k) (pred? (vector-ref a kp) item)) #t)+      (vector-set! a k (vector-ref a kp))+      (set! k kp))+    (vector-set! a k item)+; save modified array, which also returns heap to caller+    (vector-set! heap 2 a)))++; Remove the highest-priority item from the heap, maintaining the heap+; condition; return a list of the highest-priority item and the new heap++(define (heap-remove heap)+  (let* ((pred? (vector-ref heap 0))+	 (k (vector-ref heap 1))+	 (a (vector-ref heap 2))+	 (kp 0)+	 (ret (if (zero? k) (raise "heap exhausted!") (vector-ref a kp)))+	 (kc #f)+	 (v #f)+	 (child (lambda (j) (+ 1 (* 2 j)))))+    (set! k (- k 1))+    (vector-set! heap 1 k)+    (set! v (vector-ref a k))+    (vector-set! a kp v)+    (set! k (- k 1))+    (set! kc (child kp))+    (when (and (< kc k) (pred? (vector-ref a (+ kc 1))+			       (vector-ref a kc)))+	  (set! kc (+ kc 1)))+    (while (and (<= (child kp) k) (pred? (vector-ref a kc) v))+	   (vector-set! a kp (vector-ref a kc))+	   (set! kp kc)+	   (set! kc (child kp))+	   (when (and (< kc k) (pred? (vector-ref a (+ kc 1))+				      (vector-ref a kc)))+		 (set! kc (+ kc 1))))+    (vector-set! a kp v)+    (vector-set! heap 2 a)+    (list ret heap)))++; Insert an item into a heap, updating the heap in place++(defmacro (heap-insert! heap item)+  `(set! ,heap (heap-insert ,heap ,item)))++; Remove the highest-priority item from the heap, updating the heap+; in place, and return the highest-priority item++(defmacro (heap-remove! heap)+  (let ((l (new-symbol)))+    `(let ((,l (heap-remove ,heap)))+       (set! ,heap (cadr ,l))+       (car ,l))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; debugging stuff++(define (display-heap heap label)+  (letrec* ((k (vector-ref heap 1))+	    (a (vector-ref heap 2))+	    (i 0)+	    (target 1)+	    (nrows (ilog 2 k))+	    (sp-count (lambda (x)+			(if (zero? x) 1 (+ 2 (* 2 (sp-count (- x 1)))))))+	    (nsp (sp-count nrows)))+    (write-string label #\newline)+    (do ((i 0 (+ i 1)))+	((>= i k) #t)+      (display (vector-ref a i))+      (if (= (+ i 1) target)+	  (begin (newline)+		 (set! target (+ 1 (* 2 target)))+		 (set! nsp (/ (- nsp 2) 2)))+	  (apply write-string (replicate #\space nsp))))+    (newline)))++; Check that the specified heap condition is met at the given index:+; compare value against its parent, which must satisfy (pred? parent child).+; Due to possibility of equality, check for existence of failure condition+; (pred? child parent) instead of success condition (pred? parent child).++(define (heap-check-one heap cur)+  (let ((pred? (vector-ref heap 0))+	(k (vector-ref heap 1))+	(a (vector-ref heap 2))+	(parent (lambda (j) (quotient (- j 1) 2))))+    (cond ((or (negative? cur) (>= cur k))+	   (raise "requested index is out of bounds!"))+	  ((zero? cur) (write-string "heap root\n"))+	  (else (let* ((cp (parent cur))+		       (vc (vector-ref a cur))+		       (vp (vector-ref a cp)))+		  (when (pred? vc vp)+			(write-string "heap condition not satisfied between ")+			(display vp)+			(write-string " at " (number->string cp) " and ")+			(display vc)+			(write-string " at " (number->string cur)+				      #\newline)))))))++; Check that the heap condition is met at all indices++(define (heap-check-all heap)+  (let ((k (vector-ref heap 1))+	(i 1))+    (do ((i 1 (+ i 1)))+	((>= i k) #t)+      (heap-check-one heap i))))++(define (test pred . vals)+  (let ((hp (heap-new pred 10))+	(i #f))+    (until (null? vals)+	   (heap-insert! hp (car vals))+	   (set! vals (cdr vals)))+    (heap-check-all hp)+    (while (positive? (vector-ref hp 1))+	   (set! i (heap-remove! hp))+	   (heap-check-all hp)+	   (write-string "removed ")+	   (display i)+	   (newline))))

@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: regexp.scm,v 1.12 2009-06-26 05:22:27 uwe Exp $+; $Id: regexp.scm,v 1.13 2009-06-29 00:25:19 uwe Exp $ ; BSD3... but if you use this for anything serious, you gotta be kidding  ; grammar for regular expressions: precedence is (highest to lowest)@@ -321,7 +321,7 @@ 		      ((>= i n) #t) 		    (set! cur (vector-ref vec i)) 		    (set! new cur)-		    (bitset-foreach+		    (bitset-for-each 		     cur (lambda (j) 			   (set! new (bitset-or new (vector-ref vec j))))) 		    (unless (bitset-equal? new cur)@@ -347,7 +347,7 @@ 	     (lambda (s) 	       (set! eps-union 		     (bitset-or eps-union (find-eps-closure s nfa))))))-    (bitset-foreach set merge-eps-closure)+    (bitset-for-each set merge-eps-closure)     eps-union))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -417,12 +417,12 @@  ; (bitset-foldl (bitset-or . (find-transitions s nfa)) (bitset-new) eps-union) -    (bitset-foreach eps-union-		    (lambda (s)-		      (set! new-sts-			    (bitset-or new-sts-				       (foldl p-trans (bitset-new)-					      (find-transitions s nfa))))))+    (bitset-for-each eps-union+		     (lambda (s)+		       (set! new-sts+			     (bitset-or new-sts+					(foldl p-trans (bitset-new)+					       (find-transitions s nfa))))))     new-sts))  ; Make a series of transitions@@ -525,10 +525,10 @@       (let ((start #\<)) 	(if (bitset-empty? cur) 	    (write-string start)-	    (bitset-foreach cur (lambda (j)-				  (write-string start)-				  (set! start #\space)-				  (write-string (number->string j)))))+	    (bitset-for-each cur (lambda (j)+				   (write-string start)+				   (set! start #\space)+				   (write-string (number->string j))))) 	(write-string ">"))       (display cur))) 

@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: set.scm,v 1.8 2009-06-26 05:22:27 uwe Exp $+; $Id: set.scm,v 1.9 2009-06-29 00:25:19 uwe Exp $ ; BSD3  ; This could all go into stdlib?@@ -182,11 +182,11 @@  ; Apply a function to each member of a set -(define (set-foreach set fn)+(define (set-for-each set fn)   (map fn set)) -(define (intset-foreach set fn)+(define (intset-for-each set fn)   (map fn set)) -(define (bitset-foreach set fn)+(define (bitset-for-each set fn)   (map fn (bitset->list set)))