# HG changeset patch # User Steve Losh # Date 1582940195 18000 # Node ID c5a16c723abb21de8954b69bd3105796cb789a49 # Parent c2a0734fb39e5491518c57cea43904a4ac911b5c Clean up, remove webshit diff -r c2a0734fb39e -r c5a16c723abb Makefile --- 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)$$') diff -r c2a0734fb39e -r c5a16c723abb cacl.asd --- 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"))))) diff -r c2a0734fb39e -r c5a16c723abb package.lisp --- 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)) diff -r c2a0734fb39e -r c5a16c723abb src/base.lisp --- 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))) diff -r c2a0734fb39e -r c5a16c723abb src/json.lisp --- 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))))) - - diff -r c2a0734fb39e -r c5a16c723abb src/package.lisp --- /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)) diff -r c2a0734fb39e -r c5a16c723abb vendor/make-quickutils.lisp --- 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") diff -r c2a0734fb39e -r c5a16c723abb vendor/quickutils-package.lisp --- 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) - diff -r c2a0734fb39e -r c5a16c723abb vendor/quickutils.lisp --- 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 ;;;;