--- a/Makefile Fri Feb 28 13:33:54 2020 -0500
+++ b/Makefile Fri Feb 28 20:36:35 2020 -0500
@@ -1,12 +1,6 @@
-.PHONY: all vendor
-
-all: vendor build/cacl-sbcl build/cacl-ccl build/cacl-abcl build/cacl-ecl build/cacl.1
+.PHONY: all
-# Vendor ----------------------------------------------------------------------
-vendor/quickutils.lisp: vendor/make-quickutils.lisp
- cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
-
-vendor: vendor/quickutils.lisp
+all: build/cacl-sbcl build/cacl-ccl build/cacl-abcl build/cacl-ecl build/cacl.1
# Build -----------------------------------------------------------------------
lisps := $(shell ffind '\.(asd|lisp)$$')
--- a/cacl.asd Fri Feb 28 13:33:54 2020 -0500
+++ b/cacl.asd Fri Feb 28 20:36:35 2020 -0500
@@ -6,20 +6,15 @@
:version "0.0.1"
:depends-on (:adopt
+ :alexandria
:losh
- :drakma
- :flexi-streams
:iterate
:str
- :uiop
- :yason)
+ :uiop)
:serial t
- :components ((:module "vendor" :serial t
- :components ((:file "quickutils-package")
- (:file "quickutils")))
- (:file "package")
+ :components (
(:module "src" :serial t
- :components ((:file "base")
- (:file "json")
+ :components ((:file "package")
+ (:file "base")
(:file "math")))))
--- a/package.lisp Fri Feb 28 13:33:54 2020 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(defpackage :cacl
- (:use :cl :cacl.quickutils :losh :iterate)
- (:export :run :toplevel))
--- a/src/base.lisp Fri Feb 28 13:33:54 2020 -0500
+++ b/src/base.lisp Fri Feb 28 20:36:35 2020 -0500
@@ -74,21 +74,6 @@
(defun pbpaste ()
(values (sh '("pbpaste") :output t)))
-(defgeneric ref% (object key))
-
-(defmethod ref% ((object hash-table) key)
- (gethash key object))
-
-(defmethod ref% ((object vector) key)
- (aref object key))
-
-(defun ref (object &rest keys)
- (recursively ((object object)
- (keys keys))
- (if (null keys)
- object
- (recur (ref% object (first keys)) (rest keys)))))
-
;;;; Help ---------------------------------------------------------------------
(defun first-letter (command)
@@ -162,7 +147,7 @@
(defmacro define-command% (symbol args read-only &body body)
(multiple-value-bind (forms declarations documentation)
- (parse-body body :documentation t)
+ (alexandria:parse-body body :documentation t)
`(progn
(defmethod command ((symbol (eql ',symbol)))
(,(if read-only 'with-read-only-args 'with-args) ,args
@@ -176,12 +161,12 @@
(let ((read-only (member '&read-only args))
(args (remove '&read-only args)))
`(progn ,@(iterate
- (for symbol :in (ensure-list symbol-or-symbols))
+ (for symbol :in (alexandria: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")))
+ (let ((args (alexandria:make-gensym-list argument-count "ARG")))
`(define-command ,symbols ,args
(push! (,lisp-function ,@args)))))
@@ -203,20 +188,6 @@
"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) ()
@@ -272,11 +243,6 @@
(throw :do-not-add-undo-state nil))
-;;;; Commands/Objects ---------------------------------------------------------
-(define-command ref (object key)
- (push! (ref object key)))
-
-
;;;; Commands/System ----------------------------------------------------------
(define-command doc (symbol)
"Print the documentation for the symbol at the top of the stack."
@@ -321,7 +287,7 @@
;;;; REPL ---------------------------------------------------------------------
(defmacro with-errors-handled (&body body)
- (with-gensyms (old-stack)
+ (alexandria:with-gensyms (old-stack)
`(let ((,old-stack *stack*))
(handler-case (progn ,@body)
(error (e)
@@ -349,33 +315,10 @@
(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))))
+ (format t "~{~A~^ ~}" (reverse stack)))
(write-char #\))
(terpri)
(force-output))
@@ -460,7 +403,7 @@
:reduce (constantly nil)))
- (defparameter *ui*
+(defparameter *ui*
(adopt:make-interface
:name "cacl"
:usage "[OPTIONS]"
@@ -476,18 +419,18 @@
*o-no-inform*)))
- (defun toplevel ()
- ;; ccl clobbers the pprint dispatch table when dumping an image, no idea why
- (set-pprint-dispatch 'hash-table 'losh:pretty-print-hash-table)
- (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
- (when (gethash 'help options)
- (adopt:print-help-and-exit *ui*))
- (when (gethash 'inform options)
- (print-version))
- (when-let ((rc (gethash 'rcfile options)))
- (load rc :if-does-not-exist nil))
- (when arguments
- (cerror "Ignore them" "Unrecognized command-line arguments: ~S" arguments))
- (run)))
+(defun toplevel ()
+ ;; ccl clobbers the pprint dispatch table when dumping an image, no idea why
+ (set-pprint-dispatch 'hash-table 'losh:pretty-print-hash-table)
+ (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
+ (cond ((gethash 'help options)
+ (adopt:print-help-and-exit *ui*))
+ (arguments
+ (cerror "Ignore them" "Unrecognized command-line arguments: ~S" arguments)))
+ (when (gethash 'inform options)
+ (print-version))
+ (when-let ((rc (gethash 'rcfile options)))
+ (load rc :if-does-not-exist nil))
+ (run)))
--- a/src/json.lisp Fri Feb 28 13:33:54 2020 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-(in-package :cacl)
-
-(defun decode-json% (string)
- (let ((yason:*parse-json-booleans-as-symbols* t)
- (yason:*parse-json-arrays-as-vectors* t))
- (yason:parse string)))
-
-(defun encode-json% (json &key indent)
- (with-output-to-string (s)
- (yason:encode json (if indent (yason:make-json-output-stream s) s))))
-
-
-(define-command (decode-json dj) (string)
- (etypecase string
- (string (push! (decode-json% string)))))
-
-(define-command (encode-json ej) (object)
- (etypecase object
- ((or hash-table vector null number (member yason:true yason:false) string)
- (push! (encode-json% object)))))
-
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp Fri Feb 28 20:36:35 2020 -0500
@@ -0,0 +1,3 @@
+(defpackage :cacl
+ (:use :cl :losh :iterate)
+ (:export :run :toplevel))
--- a/vendor/make-quickutils.lisp Fri Feb 28 13:33:54 2020 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,20 +0,0 @@
-(ql:quickload 'quickutil)
-
-(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
-
-
- )
- :package "CACL.QUICKUTILS")
--- a/vendor/quickutils-package.lisp Fri Feb 28 13:33:54 2020 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,12 +0,0 @@
-(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)
-
--- a/vendor/quickutils.lisp Fri Feb 28 13:33:54 2020 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,280 +0,0 @@
-;;;; This file was automatically generated by Quickutil.
-;;;; 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 :READ-FILE-INTO-STRING :WITH-GENSYMS) :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 :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"))
- "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)))))
-
-
- (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.
-
-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)))))
-
-
- (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)))))
-
-
- (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."
- `(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))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry ensure-list make-gensym-list once-only parse-body
- range rcurry read-file-into-string with-gensyms with-unique-names)))
-
-;;;; END OF quickutils.lisp ;;;;