Expand the std lib a bit.

lisp/core.slosh

@@ -4,6 +4,9 @@
 (def symbol? (fn (v) (eq? (type v) :Symbol)))
 (def vec? (fn (v) (eq? (type v) :Vector)))
 (def list? (fn (v) (if (or (nil? v)(pair? v))(if (nil? (cdr v)) #t (recur (cdr v))) #f)))
+(def seq? (fn (v) (or (pair? v)(vec? v))))
+(def empty? (fn (v) (= (len v) 0)))
+(def not-empty? (fn (v) (> (len v) 0)))
 (def callable? (fn (v) (let (t (type v))(or (eq? t :Lambda)
                                              (eq? t :Continuation)
                                              (eq? t :Special)
@@ -32,12 +35,32 @@ Example:
   (macro (name args & body)
       `(def ~name (macro ~args ~@body))))
 
+#%
+Usage: (get-error exp0 ... expN) -> pair
+
+Evaluate each form (like do) but on error return (:error msg backtrace) instead of aborting.
+On success return (:ok . expN-result).
+
+If there is no error will return the value of the last expression as the cdr of
+the pair.  Always returns a pair with the first value either being :ok or :error.
+
+Section: core
+
+Example:
+(def get-error-t1 (get-error (err \"Some Error\")))
+(test::assert-equal :error (car get-error-t1))
+(test::assert-equal \"Some Error\" (cadr get-error-t1))
+(test::assert-true (vec? (caddr get-error-t1)))
+(test::assert-equal '(:ok . \"Some String\") (get-error \"Some String\"))
+(test::assert-equal '(:ok . \"Some Other String\") (get-error (def test-get-error \"Some \") (str test-get-error \"Other String\")))
+%#
 (defmacro get-error (& body)
-    `(let (old-error (on-error nil))
-        (defer (on-error old-error))
+    (let (old-error (gensym))
+    `(let (~old-error (on-error nil))
+        (defer (on-error ~old-error))
         (call/cc (fn (k)
                      (on-error (fn (key val) (k (cons key val))))
-                     (cons :ok (do ~@body))))))
+                     (cons :ok (do ~@body)))))))
 
 
 (defmacro block (& body)
@@ -109,12 +132,12 @@ Example:
 (assert-equal 11 i)
 %#
 (defmacro dotimes
-    (times body)
-    ((fn (idx-name)
-    `(if (> ~times 0)
-        (loop (~idx-name) (~times) (do
-            (~@body)
-            (if (> ~idx-name 1) (recur (- ~idx-name 1)))))))(gensym)))
+    (times & body)
+    (let (i-name (gensym))
+    `(let (~i-name 0)
+        (while (< ~i-name ~times)
+            ~@body
+            (inc! ~i-name)))))
 
 #%
 Evaluate body a number of times equal to times' numnrical value. Includes an
@@ -137,3 +160,265 @@ Example:
             (inc! ~idx-bind))))
 
 
+#%
+Usage: (when provided-condition if-true)
+
+when is a convenience function used to check a form, provided-condition,
+and run some form, if-true, if provided-condition evaluates to true.
+
+Section: conditional
+
+Example:
+
+(assert-true (when #t #t))
+(assert-false (when #t nil))
+(assert-false (when nil nil))
+%#
+(defmacro when
+    (provided-condition if-true)
+    `(if ~provided-condition ~if-true))
+
+#%
+Usage: (dyn key value expression) -> result_of_expression
+
+Creates a dynamic binding for key, assigns value to it and evals expression under it.
+Note that if key must be a symbol and is not evaluted.
+
+The binding is gone once the dyn form ends. This is basically a set! on the
+binding in an unwind protect to reset it when done.  When used on a global will
+set the first binding found and reset it when done.
+Calls to dyn can be nested and previous dynamic values will
+be restored as interior dyn's exit.
+
+Section: core
+
+Example:
+(defn test-dyn-fn () (prn \"Print dyn out\"))
+(dyn *stdout* (open \"/tmp/sl-sh.dyn.test\" :create :truncate) (test-dyn-fn))
+(test::assert-equal \"Print dyn out\" (read-line (open \"/tmp/sl-sh.dyn.test\" :read)))
+%#
+(defmacro dyn
+  (key value & expression)
+  (let (old-val (gensym))
+    `(let (~old-val ~key)
+      (defer (set! ~key ~old-val))
+      (do (set! ~key ~value) ~@expression))))
+
+#%
+Identity function.
+
+Section: core
+
+Example:
+
+(assert-equal 0 (identity 0))
+%#
+(defn identity (x) x)
+
+#%
+Produces the last element in a list or vector.  Nil if the list/vector is empty.
+
+Section: sequence
+
+Example:
+(assert-equal 3 (last '(1 2 3)))
+(assert-equal 3 (last '#(1 2 3)))
+(assert-equal nil (last '()))
+(assert-equal nil (last nil))
+(assert-equal nil (last '#()))
+%#
+(defn last
+  (obj)
+
+  (let (last-list (fn (obj)
+                       (if (nil? (cdr obj)) (car obj)
+                           (recur (cdr obj)))))
+
+    (if (vec? obj) (if (> (len obj) 0) (let (i (- (len obj) 1)) obj.~i) nil)
+        (list? obj) (last-list obj)
+        (err "Not a vector or list"))))
+
+(def butlast nil) ; predeclare and assign butlast to avoid a warning when used in butlast declaration.
+#%
+Produces the provided list minus the last element.  Nil if the list is empty or one element.
+
+Section: sequence
+
+Example:
+(assert-equal '(1 2) (butlast '(1 2 3)))
+(assert-equal '(1 2) (butlast '#(1 2 3)))
+(assert-equal nil (butlast '(1)))
+(assert-equal nil (butlast '#(1)))
+(assert-equal nil (butlast '()))
+(assert-equal nil (butlast nil))
+(assert-equal nil (butlast '#()))
+%#
+(defn butlast
+  (obj)
+  (if (vec? obj) (if (> (len obj) 0) (vec-slice obj 0 (- (len obj) 1)) nil)
+      (list? obj)
+      (let (new-link (cons nil nil))
+        (if (nil? (cdr obj))
+            (set! new-link nil)
+            (set! new-link (cons (car obj) (butlast (cdr obj)))))
+        new-link)
+      (err "Not a vector or list")))
+
+#%
+Produces the first element of the provided list or vector.  Nil if the
+list/vector is nil/empty.  Note this is like car that works for lists and
+vectors.
+
+
+Section: sequence
+
+Example:
+(assert-equal 1 (first '(1 2 3)))
+(assert-equal 1 (first '#(1 2 3)))
+(assert-equal nil (first '()))
+(assert-equal nil (first nil))
+(assert-equal nil (first '#()))
+%#
+(defn first
+  (obj)
+  (if (vec? obj) (if (empty? obj) nil obj.0)
+      (list? obj) (car obj)
+      (err "Not a vector or list")))
+
+#%
+Produces the provided list or vector minus the first element.  Nil if the
+list/vector is nil/empty or one element.  Note this is like cdr that works for
+lists and vectors.  This calls vec-slice to create a new vector when called with
+a vector (i.e. is much more efficient with lists).
+
+Section: sequence
+
+
+Example:
+(assert-equal '(2 3) (rest '(1 2 3)))
+(assert-equal '(2 3) (rest '#(1 2 3)))
+(assert-equal nil (rest '(1)))
+(assert-equal nil (rest '#(1)))
+(assert-equal nil (rest '()))
+(assert-equal nil (rest nil))
+(assert-equal nil (rest '#()))
+%#
+(defn rest
+  (obj)
+  (if (vec? obj) (vec-slice obj 1)
+      (list? obj) (cdr obj)
+      (err "Not a vector or list")))
+
+
+#%
+Loops over each element in a sequence.  Simple version that works with lists and
+vectors, use iterator::for in general.
+
+Section: sequence
+
+Example:
+(def i 0)
+(seq-for x in '(1 2 3 4 5 6) (set! i (+ 1 i)))
+(assert-equal 6 i)
+%#
+(defmacro seq-for
+  (bind in items & body)
+  (if (not (eq? in 'in)) (err "Invalid seq-for: (for [i] in [sequence] (body))"))
+          `((fn (lst)
+              (if (not-empty? lst)
+                  (let (~bind (first lst))
+                    ~@body
+                    (recur (rest lst)))))~items))
+
+#%
+Usage: (match condition (value form*)*) -> result
+
+Evaluate condition and look for matching value in each branch of type
+(value form*). Form(s) will be wrapped in an implicit do. Use nil to take
+action if no match (encouraged!).
+
+Section: conditional
+
+Example:
+
+(defn select-option (a)
+    (match a (1 \"opt-one\")
+             (2 (set! b 5) \"opt-two\")
+             (3 (str \"opt\" \"-three\"))))
+(defn select-option-def (a)
+    (match a (1 \"opt-one\")
+             (2 \"opt-two\")
+             (3 (str \"opt\" \"-three\"))
+             (nil \"default\")))
+(def b 0)
+(assert-equal b 0)
+(assert-equal \"opt-one\" (select-option 1))
+(assert-equal \"opt-two\" (select-option 2))
+(assert-equal b 5)
+(assert-equal \"opt-three\" (select-option 3))
+(assert-equal #f (select-option 4))
+(assert-equal \"opt-one\" (select-option-def 1))
+(assert-equal \"opt-two\" (select-option-def 2))
+(assert-equal \"opt-three\" (select-option-def 3))
+(assert-equal \"default\" (select-option-def 4))
+%#
+(defmacro match
+  (condition & branches)
+  ((fn ()
+       (let (make-action (fn (action)
+                              (if (seq? action)
+                                  `(do ~@action)
+                                  `action))
+             make-cond (fn (condition val action others)
+                            (if (nil? val) (make-action action)
+                                (if (empty? others) `((= ~condition ~val) ~(make-action action))
+                                    `((equal? ~condition ~val) ~(make-action action) ~@(make-cond condition (first (first others)) (rest (first others)) (rest others))))))
+             cond-name condition)
+         `(if ~@(make-cond cond-name (first (first branches)) (rest (first branches)) (rest branches)))))))
+
+
+#%
+Usage: (cond ((test form*)*) -> result
+
+Evaluate each test in order.  If it is true then evaluate the form(s) in an
+implicit do and return the result.  Stop evaluting at the first true test.
+Return nil if no conditions are true.
+
+Section: conditional
+
+Example:
+
+(defn select-option (a)
+    (cond ((= a 1) \"opt-one\")
+          ((= a 2) (set! b 5) \"opt-two\")
+          ((= a 3) (str \"opt\" \"-three\"))))
+(defn select-option-def (a)
+    (cond ((= a 1) \"opt-one\")
+          ((= a 2) \"opt-two\")
+          ((= a 3) (str \"opt\" \"-three\"))
+          (#t \"default\")))
+(def b 0)
+(assert-equal \"opt-one\" (select-option 1))
+(assert-equal b 0)
+(assert-equal \"opt-two\" (select-option 2))
+(assert-equal b 5)
+(assert-equal \"opt-three\" (select-option 3))
+(assert-equal nil (select-option 4))
+(assert-equal \"opt-one\" (select-option-def 1))
+(assert-equal \"opt-two\" (select-option-def 2))
+(assert-equal \"opt-three\" (select-option-def 3))
+(assert-equal \"default\" (select-option-def 4))
+%#
+(defmacro cond
+  (& branches)
+  ((fn ()
+       (let (make-action (fn (action)
+                              (if (seq? action)
+                                  `(do ~@action)
+                                  `action))
+             make-cond (fn (condition action others)
+                            (if (empty? others)
+                                `(~condition ~(make-action action) nil)
+                                `(~condition ~(make-action action) ~@(make-cond (first (first others)) (rest (first others)) (rest others))))))
+         `(if ~@(make-cond (first (first branches)) (rest (first branches)) (rest branches)))))))
+