# HG changeset patch # User Steve Losh # Date 1521392761 14400 # Node ID 597bba1ad5991a2ed155e91c201a4446c8a5126d # Parent 81e3e4a719c0d78b8ae92c439b537cad0c25244c Set up some basic help infrastructure diff -r 81e3e4a719c0 -r 597bba1ad599 src/build.lisp --- 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) diff -r 81e3e4a719c0 -r 597bba1ad599 src/main.lisp --- 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 diff -r 81e3e4a719c0 -r 597bba1ad599 vendor/make-quickutils.lisp --- 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 ) diff -r 81e3e4a719c0 -r 597bba1ad599 vendor/quickutils.lisp --- 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 ;;;;