--- a/src/build.lisp Sun Mar 18 12:00:44 2018 -0400
+++ b/src/build.lisp Sun Mar 18 13:06:01 2018 -0400
@@ -1,5 +1,14 @@
(ql:quickload :cacl)
+;; Run these generic functions once now so their bodies will get compiled at
+;; build time, instead of delaying it until the first time the user runs
+;; a command. In SBCL at least, compiling the generic function for the first
+;; time takes a noticeable amount of time (somewhere around a quarter of
+;; a second), so let's not be annoying.
+
+(cacl::command 'cacl::nop)
+(cacl::command-documentation 'cacl::nop)
+
#+sbcl
(progn
(sb-ext:gc :full t)
--- a/src/main.lisp Sun Mar 18 12:00:44 2018 -0400
+++ b/src/main.lisp Sun Mar 18 13:06:01 2018 -0400
@@ -8,6 +8,7 @@
(defvar *running* nil)
(defvar *stack* nil)
(defvar *previous* nil)
+(defvar *commands* nil)
;;;; Stack --------------------------------------------------------------------
@@ -92,6 +93,56 @@
(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))
@@ -99,11 +150,35 @@
(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 `(defmethod command ((symbol (eql ',symbol)))
- (with-args ,args
- ,@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)))
@@ -120,7 +195,6 @@
(define-constant-command pi pi)
(define-constant-command tau tau)
-
(define-simple-command (!) 1 factorial)
(define-simple-command (*) 2)
(define-simple-command (+) 2)
@@ -153,12 +227,13 @@
(define-simple-command (tan) 1)
(define-simple-command (truncate trunc tr) 1 truncate)
-(define-command (float fl) (x)
- (push! (coerce x 'double-float)))
+
(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)
@@ -168,37 +243,52 @@
(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) ()
@@ -215,10 +305,34 @@
(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)
- ;; todo figure out how the christ to undo this
+ "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 ()
@@ -227,6 +341,16 @@
(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))
@@ -279,13 +403,6 @@
(princ "? ")
(force-output))
-(defun print-version ()
- (format t "CACL v0.0.0 (~A)~%"
- #+sbcl 'sbcl
- #+ccl 'ccl
- #+ecl 'ecl
- #+abcl 'abcl))
-
(defun run ()
(setf *running* t
--- a/vendor/make-quickutils.lisp Sun Mar 18 12:00:44 2018 -0400
+++ b/vendor/make-quickutils.lisp Sun Mar 18 13:06:01 2018 -0400
@@ -6,12 +6,13 @@
:compose
:curry
+ :ensure-list
+ :make-gensym-list
:once-only
- :with-gensyms
+ :parse-body
+ :range
:rcurry
- :make-gensym-list
- :ensure-list
- :range
+ :with-gensyms
)
--- a/vendor/quickutils.lisp Sun Mar 18 12:00:44 2018 -0400
+++ b/vendor/quickutils.lisp Sun Mar 18 13:06:01 2018 -0400
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ONCE-ONLY :WITH-GENSYMS :RCURRY :MAKE-GENSYM-LIST :ENSURE-LIST :RANGE) :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 :WITH-GENSYMS) :ensure-package T :package "CACL.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "CACL.QUICKUTILS")
@@ -14,9 +14,9 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :COMPOSE :CURRY :ONCE-ONLY
- :STRING-DESIGNATOR :WITH-GENSYMS
- :RCURRY :ENSURE-LIST :RANGE))))
+ :COMPOSE :CURRY :ENSURE-LIST
+ :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY
+ :STRING-DESIGNATOR :WITH-GENSYMS))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -90,6 +90,13 @@
(apply ,fun ,@curries more)))))
+ (defun ensure-list (list)
+ "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
+ (if (listp list)
+ list
+ (list list)))
+
+
(defmacro once-only (specs &body forms)
"Evaluates `forms` with symbols specified in `specs` rebound to temporary
variables, ensuring that each initform is evaluated only once.
@@ -129,6 +136,46 @@
,@forms)))))
+ (defun parse-body (body &key documentation whole)
+ "Parses `body` into `(values remaining-forms declarations doc-string)`.
+Documentation strings are recognized only if `documentation` is true.
+Syntax errors in body are signalled and `whole` is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+
+ (defun range (start end &key (step 1) (key 'identity))
+ "Return the list of numbers `n` such that `start <= n < end` and
+`n = start + k*step` for suitable integers `k`. If a function `key` is
+provided, then apply it to each number."
+ (assert (<= start end))
+ (loop :for i :from start :below end :by step :collecting (funcall key i)))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
@@ -172,33 +219,8 @@
unique symbol the named variable will be bound to."
`(with-gensyms ,names ,@forms))
-
- (defun rcurry (function &rest arguments)
- "Returns a function that applies the arguments it is called
-with and `arguments` to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- (multiple-value-call fn (values-list more) (values-list arguments)))))
-
-
- (defun ensure-list (list)
- "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
- (if (listp list)
- list
- (list list)))
-
-
- (defun range (start end &key (step 1) (key 'identity))
- "Return the list of numbers `n` such that `start <= n < end` and
-`n = start + k*step` for suitable integers `k`. If a function `key` is
-provided, then apply it to each number."
- (assert (<= start end))
- (loop :for i :from start :below end :by step :collecting (funcall key i)))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry once-only with-gensyms with-unique-names rcurry
- make-gensym-list ensure-list range)))
+ (export '(compose curry ensure-list make-gensym-list once-only parse-body
+ range rcurry with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;