# HG changeset patch # User Steve Losh # Date 1521388612 14400 # Node ID 498989a23d4dcbe6821e692eaf0ebedaa9c7e071 Initial commit diff -r 000000000000 -r 498989a23d4d .ffignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.ffignore Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,1 @@ +docs/build diff -r 000000000000 -r 498989a23d4d .hgignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.hgignore Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,7 @@ +syntax: glob + +scratch.lisp +cacl-abcl +cacl-sbcl +cacl-ecl +cacl-ccl diff -r 000000000000 -r 498989a23d4d .lispwords diff -r 000000000000 -r 498989a23d4d LICENSE.markdown --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/LICENSE.markdown Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,19 @@ +Copyright (c) 2018 Steve Losh and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff -r 000000000000 -r 498989a23d4d Makefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,26 @@ +.PHONY: vendor binaries + +# Vendor ---------------------------------------------------------------------- +vendor/quickutils.lisp: vendor/make-quickutils.lisp + cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)' + +vendor: vendor/quickutils.lisp + +# Build ----------------------------------------------------------------------- +lisps := $(shell ffind '\.(asd|lisp)$$') + +binaries: cacl-sbcl cacl-ccl cacl-ecl cacl-abcl + +cacl-sbcl: $(lisps) + sbcl --load "src/build.lisp" + mv cacl cacl-sbcl + +cacl-ccl: $(lisps) + ccl --load "src/build.lisp" + mv cacl cacl-ccl + +cacl-ecl: $(lisps) bin/cacl-ecl + cp bin/cacl-ecl cacl-ecl + +cacl-abcl: $(lisps) bin/cacl-abcl + cp bin/cacl-abcl cacl-abcl diff -r 000000000000 -r 498989a23d4d README.markdown --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/README.markdown Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,9 @@ +cacl is Yet Another God Damn TUI RPN Calculator written in and programmable with +Common Lisp. + +* **License:** MIT +* **Mercurial:** +* **Git:** + +Works (mostly) in SBCL, CCL, ABCL, and ECL. Other implementations are untested, +but should hopefully work too. diff -r 000000000000 -r 498989a23d4d cacl.asd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cacl.asd Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,17 @@ +(asdf:defsystem :cacl + :description "RPN calculator in Common Lisp" + :author "Steve Losh " + + :license "MIT/X11" + :version "0.0.1" + + :depends-on (:losh + :iterate) + + :serial t + :components ((:module "vendor" :serial t + :components ((:file "quickutils-package") + (:file "quickutils"))) + (:file "package") + (:module "src" :serial t + :components ((:file "main"))))) diff -r 000000000000 -r 498989a23d4d package.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/package.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,3 @@ +(defpackage :cacl + (:use :cl :cacl.quickutils :losh :iterate) + (:export :run :toplevel)) diff -r 000000000000 -r 498989a23d4d src/build.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/build.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,20 @@ +(ql:quickload :cacl) + +#+sbcl +(progn + (sb-ext:gc :full t) + (sb-ext:save-lisp-and-die + "cacl" + :executable t + :compression nil + :toplevel #'cacl:toplevel + :save-runtime-options t)) + +#+ccl +(progn + (ccl:gc) + (ccl:save-application + "cacl" + :toplevel-function #'cacl:toplevel + :purify t + :prepend-kernel t)) diff -r 000000000000 -r 498989a23d4d src/main.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/main.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,305 @@ +(in-package :cacl) + +;;;; Config ------------------------------------------------------------------- +(defparameter *undo-limit* 30) + + +;;;; State -------------------------------------------------------------------- +(defvar *running* nil) +(defvar *stack* nil) +(defvar *previous* 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))) + + +;;;; Commands ----------------------------------------------------------------- +(defgeneric command (symbol)) + +(defmethod command ((symbol symbol)) + (error "Unknown command ~S" symbol)) + + +(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)))))) + +(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 (float fl) (x) + (push! (coerce x 'double-float))) +(define-command (clear cl) () + (pop-all!)) + +(define-command (float fl) (x) + (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) + (pbcopy x) + (push! x)) + +(define-command sum () + (push! (summation (pop-all!)))) + +(define-command prod () + (push! (product (pop-all!)))) + +(define-command dup (x) + (push! x x)) + +(define-command log (base number) + (push! (log number base))) + +(define-command pop () + (pop!)) + +(define-command version () + (print-version)) + +(define-command (quit q) () + (setf *running* nil)) + +(define-command (swap sw) (x y) + (push! y x)) + +(define-command reload () + (funcall (read-from-string "ql:quickload") :cacl)) + +(define-command (reverse rev) () + (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! (length *stack*))) + +(define-command base (n) + ;; todo figure out how the christ to undo this + (let ((pb *print-base*) + (rb *read-base*)) + (save-thunk (lambda () + (setf *print-base* pb + *read-base* rb)))) + (setf *print-base* n + *read-base* n)) + + +;;;; 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 print-version () + (format t "CACL v0.0.0 (~A)~%" + #+sbcl 'sbcl + #+ccl 'ccl + #+ecl 'ecl + #+abcl 'abcl)) + + +(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)) diff -r 000000000000 -r 498989a23d4d vendor/make-quickutils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/make-quickutils.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,18 @@ +(ql:quickload 'quickutil) + +(qtlc:save-utils-as + "quickutils.lisp" + :utilities '( + + :compose + :curry + :once-only + :with-gensyms + :rcurry + :make-gensym-list + :ensure-list + :range + + + ) + :package "CACL.QUICKUTILS") diff -r 000000000000 -r 498989a23d4d vendor/quickutils-package.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/quickutils-package.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,12 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package "CACL.QUICKUTILS") + (defpackage "CACL.QUICKUTILS" + (:documentation "Package that contains Quickutil utility functions.") + (:use :cl)))) + +(in-package "CACL.QUICKUTILS") + +;; need to define this here so sbcl will shut the hell up about it being +;; undefined when compiling quickutils.lisp. computers are trash. +(defparameter *utilities* nil) + diff -r 000000000000 -r 498989a23d4d vendor/quickutils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/quickutils.lisp Sun Mar 18 11:56:52 2018 -0400 @@ -0,0 +1,204 @@ +;;;; This file was automatically generated by Quickutil. +;;;; 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") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package "CACL.QUICKUTILS") + (defpackage "CACL.QUICKUTILS" + (:documentation "Package that contains Quickutil utility functions.") + (:use #:cl)))) + +(in-package "CACL.QUICKUTILS") + +(when (boundp '*utilities*) + (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION + :COMPOSE :CURRY :ONCE-ONLY + :STRING-DESIGNATOR :WITH-GENSYMS + :RCURRY :ENSURE-LIST :RANGE)))) +(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`, +using the second (optional, defaulting to `\"G\"`) argument." + (let ((g (if (typep x '(integer 0)) x (string x)))) + (loop repeat length + collect (gensym g)))) + ) ; eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; To propagate return type and allow the compiler to eliminate the IF when + ;;; it is known if the argument is function or not. + (declaim (inline ensure-function)) + + (declaim (ftype (function (t) (values function &optional)) + ensure-function)) + (defun ensure-function (function-designator) + "Returns the function designated by `function-designator`: +if `function-designator` is a function, it is returned, otherwise +it must be a function name and its `fdefinition` is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + ) ; eval-when + + (defun compose (function &rest more-functions) + "Returns a function composed of `function` and `more-functions` that applies its ; +arguments to to each in turn, starting from the rightmost of `more-functions`, +and then calling the next one with the primary value of the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (funcall f (apply g arguments))))) + more-functions + :initial-value function)) + + (define-compiler-macro compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(funcall ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "COMPOSE"))) + `(let ,(loop for f in funs for arg in args + collect `(,f (ensure-function ,arg))) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + + + (defun curry (function &rest arguments) + "Returns a function that applies `arguments` and the arguments +it is called with to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + + (define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest more) + (apply ,fun ,@curries more))))) + + + (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. + +Each of `specs` must either be a symbol naming the variable to be rebound, or of +the form: + + (symbol initform) + +Bare symbols in `specs` are equivalent to + + (symbol symbol) + +Example: + + (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) + (let ((y 0)) (cons1 (incf y))) => (1 . 1)" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + + + (deftype string-designator () + "A string designator type. A string designator is either a string, a symbol, +or a character." + `(or symbol string character)) + + + (defmacro with-gensyms (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(let ,(mapcar (lambda (name) + (multiple-value-bind (symbol string) + (etypecase name + (symbol + (values name (symbol-name name))) + ((cons symbol (cons string-designator null)) + (values (first name) (string (second name))))) + `(,symbol (gensym ,string)))) + names) + ,@forms)) + + (defmacro with-unique-names (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +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))) + +;;;; END OF quickutils.lisp ;;;;