commit c677de1b9fd0164fd10abb73f510d8a1f94e733b Spenser Truex <spensertruexonline@gmail.com> 2018-04-03 21:30:52 -0300 Added anaphoric y-combinator macro!
utils.lisp | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 59 insertions(+), 14 deletions(-)
diff --git a/utils.lisp b/utils.lisp index d72b0ab..883e5a6 100644 --- a/utils.lisp +++ b/utils.lisp @@ -1,5 +1,7 @@ ;; Export read-token read-int +(defvar *buffer-char* "") (defun numberp-char (char) + "Aux function." (or (char= #\0 char) (char= #\1 char) (char= #\2 char) @@ -11,18 +13,61 @@ (char= #\8 char) (char= #\9 char))) (defun whitespacep-char (char) + "Aux function." (or (char= #\Newline char) (char= #\Space char) (char= #\Tab char))) -(defun read-token (&optional (built-string "")) - (let ((char (read-char))) - (if (whitespacep-char char) - built-string - (read-token (concatenate 'string - built-string - (make-string 1 :initial-element char)))))) -(defun read-int (&optional (built-string "")) - (let ((char (read-char))) - (if (numberp-char char) - (read-int (concatenate 'string - built-string - (make-string 1 :initial-element char))) - (read-from-string built-string)))) +(defmacro make-read (name char-predicate end-predicate) + "Note: End predicate character gets eaten so we VALUES it. +This is a token reader with character predicates." + (with-gensyms (char str stream) + `(defun ,name (&optional (,stream *standard-input*)) + (labels ((recur (,str) + (let ((,char (read-char ,stream))) + (if ,end-predicate + (values ,str ,char) + (if ,char-predicate + (recur (concatenate 'string + ,str + (make-string 1 :initial-element ,char)))))))) + (recur ""))))) +(make-read read-token #'(lambda (x) t) #'whitespacep-char) +(make-read read-int #'numberp-char #'whitespacep-char) +(defmacro abbrev (short long) + `(defmacro ,short (&rest args) + `(,',long ,@args))) +(abbrev mvbind multiple-value-bind) +(abbrev dbind destructuring-bind) +(defmacro once-only ((&rest names) &body body) + "A macro-writing utility for evaluating code only once." + (let ((gensyms (loop for n in names collect (gensym)))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) +(defmacro with-gensyms (symbols &body body) + "Create gensyms for those symbols." + `(let (,@(mapcar #'(lambda (sym) + `(,sym ',(gensym))) symbols)) + ,@body)) +(defun y-comb (f) + "The Y-combinator from the Lambda calculus of Alonzo Church." + ((lambda (x) (funcall x x)) + (lambda (y) + (funcall f (lambda (&rest args) + (apply (funcall y y) args)))))) +;;; Example code for the y-combinator is in order: +#|(funcall (y-comb #'(lambda (FUNCTION) (lambda (n) (if (= 0 n) + (progn (print 0) 0) ; + (progn (print n) (funcall FUNCTION (- n 1))))))) 10)|# +;;; Yes it is a bit complex and redundant, so there is an anaphoric macro +(defmacro ay (lambda-list-args specific-args code) + "Like Y-combinator, but is a recursive macro. The anaphor is 'f'. Don't forget +to funcall f instead of trying to use it like an interned function." + `(funcall (y-comb #'(lambda (f) #'(lambda ,lambda-list-args + ,code))) + ,@specific-args)) +;;; Example code for the macro: +#|(y (a b) (10 0) + (if (= 0 a) + b + (funcall f (- a 1) (progn (print b) (+ b 1)))))|# +;;; It is peano arithmetic.