From b905aeb158fd19ccf5ec78d8f7b2ea23767e6af1 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 4 Mar 2023 19:06:44 -0800 Subject: Trashed most of hyperquirks, added let+ --- hyperquirks.asd | 1 + hyperquirks.lisp | 184 +++++++++++++------------------------------------------ package.lisp | 10 +-- 3 files changed, 46 insertions(+), 149 deletions(-) diff --git a/hyperquirks.asd b/hyperquirks.asd index 7836f5a..c0ad40b 100644 --- a/hyperquirks.asd +++ b/hyperquirks.asd @@ -8,3 +8,4 @@ :serial t :components ((:file "package") (:file "hyperquirks"))) + diff --git a/hyperquirks.lisp b/hyperquirks.lisp index 70ee560..f0e8bfc 100644 --- a/hyperquirks.lisp +++ b/hyperquirks.lisp @@ -4,10 +4,41 @@ ;;; MACROS -(defmacro defvarf (var &optional val doc) - `(if (boundp ',var) - (setf ,var ,val) - (defvar ,var ,val ,doc))) +(defmacro let+ (bindings &body body) + "General purpose binding. Normal let bindings, destructuring-binds, +and multiple-value-binds all in the same form. + +(let+ ((x + 10) + ((y z . w) + (list 1 2 3 4 5)) + (p q r + (values :oh :my :goodness))) + + (list x y x w p q r)) + +;; returns +(10 1 2 (3 4 5) :oh :my :goodness) +" + (flet ((destructuring-binding-p (binding) + (and (consp (first binding)) + (every #'symbolp (first binding)))) + (mvb-binding-p (binding) + (and (every #'symbolp (butlast binding)) + (consp (first (last binding)))))) + (loop + :with body = `(progn ,@body) + :for binding :in (reverse bindings) + :when (destructuring-binding-p binding) + :do (setf body + `(destructuring-bind ,(first binding) ,(second binding) + ,body)) + :when (mvb-binding-p binding) + :do (setf body + `(multiple-value-bind + ,(butlast binding) ,(first (last binding)) + ,body)) + :finally (return body)))) (defmacro imperative (&body body) "Evaluate expressins in BODY in sequence. Expressions that look @@ -54,60 +85,14 @@ returned from. (expander (rest body))))))) `(block () ,@(expander body)))) -(defmacro >> (ob &rest accessors) - "Chain access to OB." - (let* ((tmpvar - (gensym)) - (block-name - (gensym)) - (body - (loop for a in accessors - when (symbolp a) - collect `(setf ,tmpvar (funcall ',a ,tmpvar)) - else - collect `(setf ,tmpvar (funcall ,a ,tmpvar))))) - `(block ,block-name - (let ((,tmpvar ,ob)) - ,@body)))) - - -(defmacro ?> ((&key default (test 'null)) ob &rest accessors) - "Chain access to OB, returning DEFAULT the first time TEST returns null. -E.g. - - -> (let ((num-tree '(1 (2 3 (4 5) 6)))) - (?> num-tree second third fourth)) -NIL -> (let ((num-tree '(1 (2 3 (4 5) 6)))) - (?> num-tree second third first)) -4 -" - (let* ((tmpvar - (gensym "TEMP")) - (block-name - (gensym "BLOCK")) - (body - (loop for a in accessors - collect `(when (funcall ',test ,tmpvar) - (return-from ,block-name ,default)) - when (symbolp a) - collect `(setf ,tmpvar (funcall ',a ,tmpvar)) - else - collect `(setf ,tmpvar (funcall ,a ,tmpvar))))) - `(block ,block-name - (let ((,tmpvar ,ob)) - ,@body)))) - - -(defmacro imperative-cond (&body clauses) +(defmacro binding-cond (&body clauses) "Like cond except the first form of every clause is a binding form alá IMPERATIVE. E.g. -(imperative-cond +(binding-cond ((:= x (and (zerop (random 2)) 10) y 11) (list :x x :y y)) @@ -129,55 +114,6 @@ Otherwise 12 would be returned." collect `(when (and ,@vars) (return (progn ,@body)))))) `(imperative ,@imperative-body))) -(defmacro with-plist (keys plist &body body) - "KEYS is a list, each member of which is either a symbol or a pair of symbols. - -If a member is just a symbol, say KEY, then it is treated as the name -of a symbol-macro (defined using symbol-macrolet) that expands to the -expression (getf PLIST KEY). In this case, KEY is not allowed to be a -keyword symbol. - -If a member is a pair of symbols, it is of the form (VAR KEY). Here, -key is a valid key into the PLIST and VAR is the name of the symbol -macrolet that will be bound to (getf PLIST KEY). - -EXAMPLE: - -(let ((pl - (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum))) - (hq:with-plist (name (age :age) (job :|currentJob|)) pl - (setf age (1+ age)) - (format t \"~a the ~a had a birthday, and is now ~a years old~%\" - name job age) - pl)) - -The above would print out: -colin the CRUMB-BUM had a birthday, and is now 41 years old - -And would return -(NAME \"colin\" :AGE 41 :|currentJob| :CRUMB-BUM)" - - (let* ((plist-var - (gensym)) - (macrolet-bindings - (loop for term in keys - when (consp term ) - collect (destructuring-bind (var key) term - `(,var (getf ,plist-var ',key))) - else - collect `(,term (getf ,plist-var ',term))))) - `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body)))) - -(defmacro with-leaves (leaf-var tree &body body) - "Binds each atom in TREE to LEAF-VAR and then executes BODY." - (let ((tree-var (gensym)) - (ignore-var (gensym))) - `(let ((,tree-var ,tree)) - (tree-equal ,tree-var ,tree-var - :test (lambda (,leaf-var ,ignore-var) - (declare (ignore ,ignore-var)) - ,@body - t))))) @@ -202,47 +138,11 @@ E.g. (case (length ,rest-args) ,@clauses)))) -;;; LIST FUNCTIONS - -(defun group (n xs &optional default) - "Group a list XS into consequtive sublists of size N, using the -DEFAULT to fill in any remainder in the case the length of XS is not -neatly divisible by N." - (loop - with len = (length xs) - for start from 0 to len by n - for end = (+ start n) - when (<= end len) - collect (subseq xs start end) - when (< start len end) - collect (nconc (subseq xs start) - (loop repeat (- end len) collect default)))) - -;;; STRING FUNCTIONS - -(defun tabulate - (objects line-width col-count - &key - (default-fill #\space) - (stream t) - (object-formatter "~a")) -"Print a table of OBJECTS to STREAM. The table will be LINE-WIDTH -chracters wide and each line will have COL-COUNT columns. - -The objects are formatted with the format string OBJECT-FORMATTER, -which defaults to ~a. DEFAULT-FILL is used to fill in blanks in the -table." - (let ((row-format - (apply 'concatenate 'string - "~" (prin1-to-string line-width) "<" - (loop for i from 1 to col-count - collect object-formatter - when (< i col-count) - collect "~;" - else - collect "~>~%")))) - (dolist (g (group col-count objects default-fill)) - (apply #'format stream row-format g)))) + + + + + diff --git a/package.lisp b/package.lisp index b59340f..f3b157c 100644 --- a/package.lisp +++ b/package.lisp @@ -4,12 +4,8 @@ (:use #:cl) (:nicknames #:hq) (:export - #:defvarf + #:let+ #:imperative - #:?> - #:>> - #:imperative-cond - #:with-plist + #:binding-cond #:defun-case - #:group - #:tabulate)) +)) -- cgit v1.2.3