--- a/cacl.asd Sun Mar 18 13:06:01 2018 -0400
+++ b/cacl.asd Fri Nov 09 21:30:42 2018 -0500
@@ -6,7 +6,11 @@
:version "0.0.1"
:depends-on (:losh
- :iterate)
+ :drakma
+ :flexi-streams
+ :iterate
+ :str
+ :yason)
:serial t
:components ((:module "vendor" :serial t
@@ -14,4 +18,6 @@
(:file "quickutils")))
(:file "package")
(:module "src" :serial t
- :components ((:file "main")))))
+ :components ((:file "base")
+ (:file "json")
+ (:file "math")))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/base.lisp Fri Nov 09 21:30:42 2018 -0500
@@ -0,0 +1,383 @@
+(in-package :cacl)
+
+;;;; Config -------------------------------------------------------------------
+(defparameter *undo-limit* 30)
+
+
+;;;; State --------------------------------------------------------------------
+(defvar *running* nil)
+(defvar *stack* nil)
+(defvar *previous* nil)
+(defvar *commands* nil)
+
+
+;;;; Stack --------------------------------------------------------------------
+(defun push! (&rest objects)
+ (dolist (o objects)
+ (push (if (floatp o)
+ (coerce o 'double-float)
+ o)
+ *stack*)))
+
+(defun pop! ()
+ (assert *stack* () "Cannot pop empty stack")
+ (pop *stack*))
+
+(defun pop-all! ()
+ (prog1 *stack* (setf *stack* nil)))
+
+
+(defmacro with-args (symbols &body body)
+ `(let (,@(iterate (for symbol :in (reverse symbols))
+ (collect `(,symbol (pop!)))))
+ ,@body))
+
+(defmacro with-read-only-args (symbols &body body)
+ `(let (,@(iterate (for i :from 0)
+ (for symbol :in (reverse symbols))
+ (collect `(,symbol (nth ,i *stack*)))))
+ ,@body))
+
+
+;;;; Undo ---------------------------------------------------------------------
+(defun save-stack ()
+ (unless (eql *stack* (car *previous*))
+ (push *stack* *previous*))
+ (setf *previous* (subseq *previous* 0 (min (1+ *undo-limit*)
+ (length *previous*)))))
+
+(defun save-thunk (thunk)
+ (push thunk *previous*))
+
+(defun undo ()
+ (assert (cdr *previous*) () "Cannot undo any further")
+ ;; The first element in *previous* is the current stack, so remove it.
+ (pop *previous*)
+ (let ((top (car *previous*)))
+ (etypecase top
+ (list nil)
+ (function (funcall top)
+ (pop *previous*)))
+ (setf *stack* (car *previous*))))
+
+
+;;;; Misc ---------------------------------------------------------------------
+(defun sh (command &key (input "") output)
+ (uiop:run-program command
+ :output (when output :string)
+ :input (make-string-input-stream input)))
+
+(defun pbcopy (object)
+ (sh '("pbcopy") :input (aesthetic-string object))
+ (values))
+
+(defun pbpaste ()
+ (values (sh '("pbpaste") :output t)))
+
+
+;;;; Help ---------------------------------------------------------------------
+(defun first-letter (command)
+ (let ((ch (aref (symbol-name command) 0)))
+ (if (alphanumericp ch)
+ ch
+ #\!)))
+
+(defun partition-commands (commands)
+ (mapcar (lambda (letter-and-commands)
+ (sort (second letter-and-commands) #'string<))
+ (sort (hash-table-contents (group-by #'first-letter commands))
+ #'char< :key #'first)))
+
+(defun print-version ()
+ (format t "CACL v0.0.0 (~A)~%"
+ #+sbcl 'sbcl
+ #+ccl 'ccl
+ #+ecl 'ecl
+ #+abcl 'abcl))
+
+(defun print-help ()
+ (terpri)
+ (format t "CACL is an RPN calculator written in Common Lisp.~@
+ ~@
+ The current stack is displayed above the prompt (the top is at the right).~@
+ ~@
+ Forms are read from standard input with the standard Common Lisp READ function.~@
+ This means you can put multiple things on one line if you want, like this:~@
+ ~% 1 2 +~@
+ ~@
+ What happens when a form is read depends on the form:~@
+ ~@
+ * Numbers are pushed onto the stack.~@
+ * Symbols run commands.~@
+ * Quoted forms are pushed onto the stack.~@
+ ~@
+ Type `commands` for a list of available commands.~@
+ ~@
+ To get help for a particular command, push its symbol onto the stack~@
+ and run the `doc` command:~@
+ ~% 'float doc~@
+ "))
+
+(defun print-commands ()
+ (terpri)
+ (format t "AVAILABLE COMMANDS:~@
+ ~(~{~{~A~^ ~}~%~}~)~%"
+ (partition-commands *commands*)))
+
+
+;;;; Commands -----------------------------------------------------------------
+(defgeneric command (symbol))
+
+(defmethod command ((symbol symbol))
+ (error "Unknown command ~S" symbol))
+
+
+(defgeneric command-documentation (symbol))
+
+(defmethod command-documentation (object)
+ (flet ((friendly-type (object)
+ (let ((type (type-of object)))
+ (if (consp type) (first type) type))))
+ (error "Cannot retrieve documentation for ~S ~S"
+ (friendly-type object) object)))
+
+(defmethod command-documentation ((symbol symbol))
+ (error "Unknown command ~S" symbol))
+
+
+(defmacro define-command% (symbol args read-only &body body)
+ (multiple-value-bind (forms declarations documentation)
+ (parse-body body :documentation t)
+ `(progn
+ (defmethod command ((symbol (eql ',symbol)))
+ (,(if read-only 'with-read-only-args 'with-args) ,args
+ ,@declarations
+ ,@forms))
+ (defmethod command-documentation ((symbol (eql ',symbol)))
+ ,(or documentation "No documentation provided"))
+ (pushnew ',symbol *commands*))))
+
+(defmacro define-command (symbol-or-symbols args &body body)
+ (let ((read-only (member '&read-only args))
+ (args (remove '&read-only args)))
+ `(progn ,@(iterate
+ (for symbol :in (ensure-list symbol-or-symbols))
+ (collect `(define-command% ,symbol ,args ,read-only ,@body))))))
+
+(defmacro define-simple-command
+ (symbols argument-count &optional (lisp-function (first symbols)))
+ (let ((args (make-gensym-list argument-count "ARG")))
+ `(define-command ,symbols ,args
+ (push! (,lisp-function ,@args)))))
+
+(defmacro define-constant-command (symbol value)
+ `(define-command ,symbol ()
+ (push! ,value)))
+
+
+;;;; Commands/IO --------------------------------------------------------------
+(define-command pbc (&read-only x)
+ "Copy the top element of the stack to the system clipboard.
+
+ The item will remain on the stack.
+
+ "
+ (pbcopy x))
+
+(define-command pbp ()
+ "Push the contents of the system clipboard onto the stack as a string."
+ (push! (pbpaste)))
+
+(define-command file (path)
+ "Push the contents of `path` onto the stack as a string."
+ (push! (read-file-into-string path)))
+
+(defun curl% (url)
+ (let ((body (drakma:http-request url)))
+ (etypecase body
+ (string body)
+ (vector (flexi-streams:octets-to-string body)))))
+
+(define-command curl (url)
+ "Retrieve `url` and push its contents onto the stack as a string."
+ (push! (curl% url)))
+
+
+;;;; Commands/Stack -----------------------------------------------------------
+(define-command (clear cl) ()
+ "Clear the entire stack."
+ (pop-all!))
+
+(define-command (print p) (&read-only item)
+ "Print `item`. It will remain on the stack."
+ (princ (structural-string item))
+ (terpri)
+ (force-output))
+
+(define-command (pprint pp) (&read-only item)
+ "Pretty print `item`. It will remain on the stack."
+ (pprint item)
+ (terpri)
+ (force-output))
+
+(define-command (dup d) (x)
+ "Duplicate the top element of the stack."
+ (push! x x))
+
+(define-command pop ()
+ "Pop the top element of the stack."
+ (pop!))
+
+(define-command (length len) (item)
+ (push! (length item)))
+
+(define-command (swap x) (x y)
+ "Exchange the top two elements of the stack."
+ (push! y x))
+
+(define-command (reverse rev) ()
+ "Reverse the stack."
+ (setf *stack* (reverse *stack*)))
+
+(define-command (hist history) ()
+ (let ((*read-default-float-format* 'double-float))
+ (flet ((print-entry (e)
+ (typecase e
+ (list (print-stack e))
+ (t (prin1 e) (terpri)))))
+ (mapc #'print-entry (reverse *previous*))))
+ (terpri))
+
+(define-command count ()
+ "Push the length of the stack."
+ (push! (length *stack*)))
+
+(define-command (undo un) ()
+ (undo)
+ (throw :do-not-add-undo-state nil))
+
+
+;;;; Commands/System ----------------------------------------------------------
+(define-command doc (symbol)
+ "Print the documentation for the symbol at the top of the stack."
+ (format t "~A: ~A~%" symbol (command-documentation symbol)))
+
+(define-command help ()
+ "Print some basic help information."
+ (print-help))
+
+(define-command commands ()
+ "Print a list of available commands."
+ (print-commands))
+
+(define-command reload ()
+ "Reload the entire CACL system from Quicklisp."
+ (funcall (read-from-string "ql:quickload") :cacl))
+
+(define-command (quit q) ()
+ "Quit CACL."
+ (setf *running* nil))
+
+(define-command version ()
+ "Print the version and host Lisp."
+ (print-version))
+
+(define-command nop ()
+ "Do nothing.")
+
+
+;;;; Special Forms ------------------------------------------------------------
+(defgeneric special-form (symbol &rest body))
+
+(defmacro define-special-form (symbol arguments &rest body)
+ (let ((args (gensym "ARGUMENTS")))
+ `(defmethod special-form ((symbol (eql ',symbol)) &rest ,args)
+ (destructuring-bind ,arguments ,args
+ ,@body))))
+
+(define-special-form quote (value)
+ (push! value))
+
+
+;;;; REPL ---------------------------------------------------------------------
+(defmacro with-errors-handled (&body body)
+ (with-gensyms (old-stack)
+ `(let ((,old-stack *stack*))
+ (handler-case (progn ,@body)
+ (error (e)
+ (format t "~A: ~A~%" (type-of e) e)
+ (setf *stack* ,old-stack))))))
+
+
+(defun read-input ()
+ (let ((*read-default-float-format* 'double-float)
+ (line (read-line *standard-input* nil :eof nil)))
+ (if (eq :eof line)
+ (setf *running* nil)
+ (read-all-from-string line))))
+
+(defun handle-input (input)
+ (with-errors-handled
+ (catch :do-not-add-undo-state
+ (etypecase input
+ ((or number string) (push! input))
+ (symbol (command input))
+ (cons (apply 'special-form input)))
+ (save-stack))))
+
+(defun handle-all-input ()
+ (mapc #'handle-input (read-input)))
+
+
+(defun render-stack-item (object)
+ (typecase object
+ (string (structural-string (str:prune 20 object :ellipsis "…")))
+ (t (write-to-string object :pretty t :lines 1 :level 2 :right-margin 20 :length 20))))
+
+;; (defgeneric render-stack-item (object))
+
+;; (defmethod render-stack-item ((object t))
+;; (princ-to-string object))
+
+;; (defmethod render-stack-item ((string string))
+;; (-<> string
+;; (str:replace-all (string #\newline) "⏎ " <>)
+;; (str:prune 15 <> :ellipsis "…")
+;; structural-string))
+
+;; (defmethod render-stack-item ((hash-table hash-table))
+;; "{…}")
+
+;; (defmethod render-stack-item ((array array))
+;; "#(…)")
+
+
+(defun print-stack (&optional (stack *stack*))
+ (write-char #\()
+ (let ((*read-default-float-format* 'double-float))
+ (format t "~{~A~^ ~}" (mapcar #'render-stack-item (reverse stack))))
+ (write-char #\))
+ (terpri)
+ (force-output))
+
+(defun print-prompt ()
+ (princ "? ")
+ (force-output))
+
+
+(defun run ()
+ (setf *running* t
+ *stack* nil
+ *previous* (list nil))
+ (let ((*package* (find-package :cacl)))
+ (iterate (while *running*)
+ (progn
+ (terpri)
+ (print-stack)
+ (print-prompt)
+ (handle-all-input))))
+ (values))
+
+(defun toplevel ()
+ (print-version)
+ (run))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/json.lisp Fri Nov 09 21:30:42 2018 -0500
@@ -0,0 +1,21 @@
+(in-package :cacl)
+
+(defun string-to-json (string)
+ (let ((yason:*parse-json-booleans-as-symbols* t)
+ (yason:*parse-json-arrays-as-vectors* t))
+ (yason:parse string)))
+
+(defun json-to-string (json &key indent)
+ (with-output-to-string (s)
+ (yason:encode json (if indent (yason:make-json-output-stream s) s))))
+
+
+(define-command (from-json fj) (string)
+ (etypecase string
+ (string (push! (string-to-json string)))))
+
+(define-command (to-json tj) (json)
+ (etypecase json
+ (json (push! (json-to-string json)))))
+
+
--- a/src/main.lisp Sun Mar 18 13:06:01 2018 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,422 +0,0 @@
-(in-package :cacl)
-
-;;;; Config -------------------------------------------------------------------
-(defparameter *undo-limit* 30)
-
-
-;;;; State --------------------------------------------------------------------
-(defvar *running* nil)
-(defvar *stack* nil)
-(defvar *previous* nil)
-(defvar *commands* nil)
-
-
-;;;; Stack --------------------------------------------------------------------
-(defun push! (&rest objects)
- (dolist (o objects)
- (push (if (floatp o)
- (coerce o 'double-float)
- o)
- *stack*)))
-
-(defun pop! ()
- (assert *stack* () "Cannot pop empty stack")
- (pop *stack*))
-
-(defun pop-all! ()
- (prog1 *stack* (setf *stack* nil)))
-
-
-(defmacro with-args (symbols &body body)
- `(let (,@(iterate (for symbol :in (reverse symbols))
- (collect `(,symbol (pop!)))))
- ,@body))
-
-
-;;;; Undo ---------------------------------------------------------------------
-(defun save-stack ()
- (unless (eql *stack* (car *previous*))
- (push *stack* *previous*))
- (setf *previous* (subseq *previous* 0 (min (1+ *undo-limit*)
- (length *previous*)))))
-
-(defun save-thunk (thunk)
- (push thunk *previous*))
-
-(defun undo ()
- (assert (cdr *previous*) () "Cannot undo any further")
- ;; The first element in *previous* is the current stack, so remove it.
- (pop *previous*)
- (let ((top (car *previous*)))
- (etypecase top
- (list nil)
- (function (funcall top)
- (pop *previous*)))
- (setf *stack* (car *previous*))))
-
-
-;;;; Math ---------------------------------------------------------------------
-(defun cube (number) (* number number number))
-
-(defun factorial (number)
- (iterate (for i :from 1 :to number)
- (multiplying i)))
-
-(defun binomial-coefficient (n k)
- "Return `n` choose `k`."
- ;; See https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula
- (iterate (for i :from 1 :to k)
- (multiplying (/ (- (1+ n) i) i))))
-
-
-;;;; Misc ---------------------------------------------------------------------
-(defun sh (command input)
- (declare (ignorable command input))
- #+sbcl
- (sb-ext:run-program (first command) (rest command)
- :search t
- :input (make-string-input-stream input))
- #+ccl
- (ccl:run-program (first command) (rest command)
- :input (make-string-input-stream input))
- #+abcl
- (let ((p (system:run-program (first command) (rest command)
- :input :stream
- :output t
- :wait nil)))
- (write-string input (system:process-input p))
- (close (system:process-input p)))
- #-(or sbcl ccl abcl)
- (error "Not implemented for this Lisp implementation, sorry"))
-
-(defun pbcopy (object)
- (sh '("pbcopy") (structural-string object)))
-
-
-;;;; Help ---------------------------------------------------------------------
-(defun first-letter (command)
- (let ((ch (aref (symbol-name command) 0)))
- (if (alphanumericp ch)
- ch
- #\!)))
-
-(defun partition-commands (commands)
- (mapcar (lambda (letter-and-commands)
- (sort (second letter-and-commands) #'string<))
- (sort (hash-table-contents (group-by #'first-letter commands))
- #'char< :key #'first)))
-
-(defun print-version ()
- (format t "CACL v0.0.0 (~A)~%"
- #+sbcl 'sbcl
- #+ccl 'ccl
- #+ecl 'ecl
- #+abcl 'abcl))
-
-(defun print-help ()
- (terpri)
- (format t "CACL is an RPN calculator written in Common Lisp.~@
- ~@
- The current stack is displayed above the prompt (the top is at the right).~@
- ~@
- Forms are read from standard input with the standard Common Lisp READ function.~@
- This means you can put multiple things on one line if you want, like this:~@
- ~% 1 2 +~@
- ~@
- What happens when a form is read depends on the form:~@
- ~@
- * Numbers are pushed onto the stack.~@
- * Symbols run commands.~@
- * Quoted forms are pushed onto the stack.~@
- ~@
- Type `commands` for a list of available commands.~@
- ~@
- To get help for a particular command, push its symbol onto the stack~@
- and run the `doc` command:~@
- ~% 'float doc~@
- "))
-
-(defun print-commands ()
- (terpri)
- (format t "AVAILABLE COMMANDS:~@
- ~(~{~{~A~^ ~}~%~}~)~%"
- (partition-commands *commands*)))
-
-
-;;;; Commands -----------------------------------------------------------------
-(defgeneric command (symbol))
-
-(defmethod command ((symbol symbol))
- (error "Unknown command ~S" symbol))
-
-
-(defgeneric command-documentation (symbol))
-
-(defmethod command-documentation (object)
- (flet ((friendly-type (object)
- (let ((type (type-of object)))
- (if (consp type) (first type) type))))
- (error "Cannot retrieve documentation for ~S ~S"
- (friendly-type object) object)))
-
-(defmethod command-documentation ((symbol symbol))
- (error "Unknown command ~S" symbol))
-
-
-(defmacro define-command% (symbol args &body body)
- (multiple-value-bind (forms declarations documentation)
- (parse-body body :documentation t)
- `(progn
- (defmethod command ((symbol (eql ',symbol)))
- (with-args ,args
- ,@declarations
- ,@forms))
- (defmethod command-documentation ((symbol (eql ',symbol)))
- ,(or documentation "No documentation provided"))
- (pushnew ',symbol *commands*))))
-
-(defmacro define-command (symbol-or-symbols args &body body)
- `(progn ,@(iterate
- (for symbol :in (ensure-list symbol-or-symbols))
- (collect `(define-command% ,symbol ,args ,@body)))))
-
-(defmacro define-simple-command
- (symbols argument-count &optional (lisp-function (first symbols)))
- (let ((args (make-gensym-list argument-count "ARG")))
- `(define-command ,symbols ,args
- (push! (,lisp-function ,@args)))))
-
-(defmacro define-constant-command (symbol value)
- `(define-command ,symbol ()
- (push! ,value)))
-
-
-(define-constant-command e (exp 1.0d0))
-(define-constant-command pi pi)
-(define-constant-command tau tau)
-
-(define-simple-command (!) 1 factorial)
-(define-simple-command (*) 2)
-(define-simple-command (+) 2)
-(define-simple-command (-) 2)
-(define-simple-command (/) 2)
-(define-simple-command (abs) 1)
-(define-simple-command (acos) 1)
-(define-simple-command (asin) 1)
-(define-simple-command (atan) 1)
-(define-simple-command (atan2) 2 atan)
-(define-simple-command (ceiling ceil) 1)
-(define-simple-command (choose) 2 binomial-coefficient)
-(define-simple-command (cos) 1)
-(define-simple-command (cs) 1 -)
-(define-simple-command (cube) 1)
-(define-simple-command (denom) 1 denominator)
-(define-simple-command (expt ex) 2)
-(define-simple-command (floor) 1)
-(define-simple-command (gcd) 2)
-(define-simple-command (lcm) 2)
-(define-simple-command (mod) 2)
-(define-simple-command (numer) 1 numerator)
-(define-simple-command (rat) 1 rationalize)
-(define-simple-command (rec recip) 1 /)
-(define-simple-command (rem) 2)
-(define-simple-command (round) 1)
-(define-simple-command (sin) 1)
-(define-simple-command (sqrt) 1)
-(define-simple-command (square sq) 1)
-(define-simple-command (tan) 1)
-(define-simple-command (truncate trunc tr) 1 truncate)
-
-
-(define-command (clear cl) ()
- "Clear the entire stack."
- (pop-all!))
-
-(define-command (float fl) (x)
- "Coerce the top of the stack to a DOUBLE-FLOAT."
- (push! (coerce x 'double-float)))
-
-(define-command range (from below)
- (map nil #'push! (range from below)))
-
-(define-command irange (from to)
- (map nil #'push! (range from (1+ to))))
-
-(define-command pbc (x)
- "Copy the top element of the stack to the system clipboard.
-
- SBCL only for now, sorry."
- (pbcopy x)
- (push! x))
-
-(define-command sum ()
- "Pop the entire stack, add everything together, and push the result."
- (push! (summation (pop-all!))))
-
-(define-command prod ()
- "Pop the entire stack, multiply everything together, and push the result."
- (push! (product (pop-all!))))
-
-(define-command dup (x)
- "Duplicate the top element of the stack."
- (push! x x))
-
-(define-command log (base number)
- (push! (log number base)))
-
-(define-command nop ()
- "Do nothing.")
-
-(define-command pop ()
- "Pop the top element of the stack."
- (pop!))
-
-(define-command version ()
- "Print the version and host Lisp."
- (print-version))
-
-(define-command (quit q) ()
- "Quit CACL."
- (setf *running* nil))
-
-(define-command (swap sw) (x y)
- "Swap the top two elements of the stack."
- (push! y x))
-
-(define-command reload ()
- "Reload the entire CACL system from Quicklisp."
- (funcall (read-from-string "ql:quickload") :cacl))
-
-(define-command (reverse rev) ()
- "Reverse the stack."
- (setf *stack* (reverse *stack*)))
-
-(define-command (hist history) ()
- (let ((*read-default-float-format* 'double-float))
- (flet ((print-entry (e)
- (typecase e
- (list (print (reverse e)))
- (t (print e)))))
- (mapc #'print-entry (reverse *previous*))))
- (terpri))
-
-(define-command (undo un) ()
- (undo)
- (throw :do-not-add-undo-state nil))
-
-(define-command count ()
- "Push the length of the stack."
- (push! (length *stack*)))
-
-(define-command doc (symbol)
- "Print the documentation for the symbol at the top of the stack."
- (format t "~A: ~A~%" symbol (command-documentation symbol)))
-
-(define-command help ()
- "Print some basic help information."
- (print-help))
-
-
-(define-command commands ()
- "Print a list of available commands."
- (print-commands))
-
-(define-command base (n)
- "Set the print base and read base for numbers to the top element of the stack.
-
- For example, to switch to reading and displaying numbers in binary:
-
- 2 base
-
- To switch back to base 10 you can run the command again, but you'll need to
- write the 10 in the base you've chosen! It's often easer to `undo`, or use
- the provided `base10` command.
-
- "
- (let ((pb *print-base*)
- (rb *read-base*))
- (save-thunk (lambda ()
- (setf *print-base* pb
- *read-base* rb))))
- (setf *print-base* n
- *read-base* n))
-
-(define-command base10 ()
- "Set the print base and read base for numbers to base 10."
- (let ((pb *print-base*)
- (rb *read-base*))
- (save-thunk (lambda ()
- (setf *print-base* pb
- *read-base* rb))))
- (setf *print-base* 10
- *read-base* 10))
-
-
-;;;; Special Forms ------------------------------------------------------------
-(defgeneric special-form (symbol &rest body))
-
-(defmacro define-special-form (symbol arguments &rest body)
- (let ((args (gensym "ARGUMENTS")))
- `(defmethod special-form ((symbol (eql ',symbol)) &rest ,args)
- (destructuring-bind ,arguments ,args
- ,@body))))
-
-(define-special-form quote (value)
- (push! value))
-
-
-;;;; REPL ---------------------------------------------------------------------
-(defmacro with-errors-handled (&body body)
- (with-gensyms (old-stack)
- `(let ((,old-stack *stack*))
- (handler-case (progn ,@body)
- (error (e)
- (format t "~A: ~A~%" (type-of e) e)
- (setf *stack* ,old-stack))))))
-
-
-(defun read-input ()
- (let ((*read-default-float-format* 'double-float)
- (line (read-line *standard-input* nil :eof nil)))
- (if (eq :eof line)
- (setf *running* nil)
- (read-all-from-string line))))
-
-(defun handle-input (input)
- (with-errors-handled
- (catch :do-not-add-undo-state
- (etypecase input
- (number (push! input))
- (symbol (command input))
- (cons (apply 'special-form input)))
- (save-stack))))
-
-(defun handle-all-input ()
- (mapc #'handle-input (read-input)))
-
-
-(defun print-stack ()
- (let ((*read-default-float-format* 'double-float))
- (pr (reverse *stack*))))
-
-(defun print-prompt ()
- (princ "? ")
- (force-output))
-
-
-(defun run ()
- (setf *running* t
- *stack* nil
- *previous* (list nil))
- (let ((*package* (find-package :cacl)))
- (iterate (while *running*)
- (progn
- (terpri)
- (print-stack)
- (print-prompt)
- (handle-all-input))))
- (values))
-
-(defun toplevel ()
- (print-version)
- (run))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/math.lisp Fri Nov 09 21:30:42 2018 -0500
@@ -0,0 +1,103 @@
+(in-package :cacl)
+
+(defun cube (number) (* number number number))
+
+(defun factorial (number)
+ (iterate (for i :from 1 :to number)
+ (multiplying i)))
+
+(defun binomial-coefficient (n k)
+ "Return `n` choose `k`."
+ ;; See https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula
+ (iterate (for i :from 1 :to k)
+ (multiplying (/ (- (1+ n) i) i))))
+
+
+
+(define-constant-command e (exp 1.0d0))
+(define-constant-command pi pi)
+(define-constant-command tau tau)
+
+(define-simple-command (!) 1 factorial)
+(define-simple-command (*) 2)
+(define-simple-command (+) 2)
+(define-simple-command (-) 2)
+(define-simple-command (/) 2)
+(define-simple-command (abs) 1)
+(define-simple-command (acos) 1)
+(define-simple-command (asin) 1)
+(define-simple-command (atan) 1)
+(define-simple-command (atan2) 2 atan)
+(define-simple-command (ceiling ceil) 1)
+(define-simple-command (choose) 2 binomial-coefficient)
+(define-simple-command (cos) 1)
+(define-simple-command (cs) 1 -)
+(define-simple-command (cube) 1)
+(define-simple-command (denom) 1 denominator)
+(define-simple-command (expt ex) 2)
+(define-simple-command (floor) 1)
+(define-simple-command (gcd) 2)
+(define-simple-command (lcm) 2)
+(define-simple-command (mod) 2)
+(define-simple-command (numer) 1 numerator)
+(define-simple-command (rat) 1 rationalize)
+(define-simple-command (rec recip) 1 /)
+(define-simple-command (rem) 2)
+(define-simple-command (round) 1)
+(define-simple-command (sin) 1)
+(define-simple-command (sqrt) 1)
+(define-simple-command (square sq) 1)
+(define-simple-command (tan) 1)
+(define-simple-command (truncate trunc tr) 1 truncate)
+
+(define-command (float fl) (x)
+ "Coerce the top of the stack to a DOUBLE-FLOAT."
+ (push! (coerce x 'double-float)))
+
+(define-command range (from below)
+ (map nil #'push! (range from below)))
+
+(define-command irange (from to)
+ (map nil #'push! (range from (1+ to))))
+
+(define-command base (n)
+ "Set the print base and read base for numbers to the top element of the stack.
+
+ For example, to switch to reading and displaying numbers in binary:
+
+ 2 base
+
+ To switch back to base 10 you can run the command again, but you'll need to
+ write the 10 in the base you've chosen! It's often easer to `undo`, or use
+ the provided `base10` command.
+
+ "
+ (let ((pb *print-base*)
+ (rb *read-base*))
+ (save-thunk (lambda ()
+ (setf *print-base* pb
+ *read-base* rb))))
+ (setf *print-base* n
+ *read-base* n))
+
+(define-command base10 ()
+ "Set the print base and read base for numbers to base 10."
+ (let ((pb *print-base*)
+ (rb *read-base*))
+ (save-thunk (lambda ()
+ (setf *print-base* pb
+ *read-base* rb))))
+ (setf *print-base* 10
+ *read-base* 10))
+
+(define-command sum ()
+ "Pop the entire stack, add everything together, and push the result."
+ (push! (summation (pop-all!))))
+
+(define-command prod ()
+ "Pop the entire stack, multiply everything together, and push the result."
+ (push! (product (pop-all!))))
+
+(define-command log (base number)
+ (push! (log number base)))
+
--- a/vendor/make-quickutils.lisp Sun Mar 18 13:06:01 2018 -0400
+++ b/vendor/make-quickutils.lisp Fri Nov 09 21:30:42 2018 -0500
@@ -12,6 +12,7 @@
:parse-body
:range
:rcurry
+ :read-file-into-string
:with-gensyms
--- a/vendor/quickutils.lisp Sun Mar 18 13:06:01 2018 -0400
+++ b/vendor/quickutils.lisp Fri Nov 09 21:30:42 2018 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-LIST :MAKE-GENSYM-LIST :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY :WITH-GENSYMS) :ensure-package T :package "CACL.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-LIST :MAKE-GENSYM-LIST :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY :READ-FILE-INTO-STRING :WITH-GENSYMS) :ensure-package T :package "CACL.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "CACL.QUICKUTILS")
@@ -16,6 +16,8 @@
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :CURRY :ENSURE-LIST
:ONCE-ONLY :PARSE-BODY :RANGE :RCURRY
+ :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
+ :READ-FILE-INTO-STRING
:STRING-DESIGNATOR :WITH-GENSYMS))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
@@ -176,6 +178,58 @@
(multiple-value-call fn (values-list more) (values-list arguments)))))
+ (defmacro with-open-file* ((stream filespec &key direction element-type
+ if-exists if-does-not-exist external-format)
+ &body body)
+ "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+ (once-only (direction element-type if-exists if-does-not-exist external-format)
+ `(with-open-stream
+ (,stream (apply #'open ,filespec
+ (append
+ (when ,direction
+ (list :direction ,direction))
+ (when ,element-type
+ (list :element-type ,element-type))
+ (when ,if-exists
+ (list :if-exists ,if-exists))
+ (when ,if-does-not-exist
+ (list :if-does-not-exist ,if-does-not-exist))
+ (when ,external-format
+ (list :external-format ,external-format)))))
+ ,@body)))
+
+
+ (defmacro with-input-from-file ((stream-name file-name &rest args
+ &key (direction nil direction-p)
+ &allow-other-keys)
+ &body body)
+ "Evaluate `body` with `stream-name` to an input stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+ (declare (ignore direction))
+ (when direction-p
+ (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
+ `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+ ,@body))
+
+
+ (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+ "Return the contents of the file denoted by `pathname` as a fresh string.
+
+The `external-format` parameter will be passed directly to `with-open-file`
+unless it's `nil`, which means the system default."
+ (with-input-from-file
+ (file-stream pathname :external-format external-format)
+ (let ((*print-pretty* nil))
+ (with-output-to-string (datum)
+ (let ((buffer (make-array buffer-size :element-type 'character)))
+ (loop
+ :for bytes-read = (read-sequence buffer file-stream)
+ :do (write-sequence buffer datum :start 0 :end bytes-read)
+ :while (= bytes-read buffer-size)))))))
+
+
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
@@ -221,6 +275,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose curry ensure-list make-gensym-list once-only parse-body
- range rcurry with-gensyms with-unique-names)))
+ range rcurry read-file-into-string with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;