From 0981a1131aba9233fc0ce2be77d5bc65fae88554 Mon Sep 17 00:00:00 2001 From: ~keith Date: Thu, 13 Jun 2024 18:50:15 -0400 Subject: [PATCH] Control flow macros --- control-flow.lisp | 44 ++++++++++++++++++++++++++++++++++++++++++++ exports.lisp | 26 +++++++++++++++----------- syrup.asd | 5 +++-- syrup.lisp | 7 ++++++- 4 files changed, 68 insertions(+), 14 deletions(-) create mode 100644 control-flow.lisp diff --git a/control-flow.lisp b/control-flow.lisp new file mode 100644 index 0000000..3d4a7bf --- /dev/null +++ b/control-flow.lisp @@ -0,0 +1,44 @@ +(in-package #:syrup) + +(defun translate-if* (test body) + (let ((then-forms + ;; Collect all un-enclosed forms at the start of the body, and skip past them. + ;; These forms are considered part of an implicit :THEN clause. + (loop :for tail :on body + :for form := (car tail) + :until (and (consp form) (find (car form) '(:then :else-if :else))) + :collect form + :finally (setf body tail))) + (else-if-forms nil) + (else-forms nil)) + ;; Handle :THEN, :ELSE, and :ELSE-IF clauses + (loop :for tail :on body + :for form := (car tail) + :do + (unless (consp form) (error "Not a valid IF* clause: ~S" form)) + (case (car form) + (:then + (when then-forms (error "Duplicate :THEN clause")) + (setf then-forms (cdr form))) + (:else + (when (cdr tail) (error "Junk after :ELSE clause: ~S" (cdr tail))) + (setf else-forms (cdr form)) + (loop-finish)) + (:else-if ;; handle these recursively + (setf else-forms (list (translate-if* (cadr form) `((:then ,@(cddr form)) ,@(cdr tail))))) + (loop-finish)) + (t (error "Not a valid IF* clause: ~S" form)))) + ;; Now build the if statement + (labels ((maybe-progn (x) + (if (cdr x) (cons 'progn x) (car x)))) + (if else-forms + `(if ,test ,(maybe-progn then-forms) ,(maybe-progn else-forms)) + `(when ,test ,@then-forms))))) +(defmacro if* (test &body body) + "An easier-to-read conditional statement." + (translate-if* test body)) + +(defmacro while (test &body body) + "Repeatedly evaluate BODY while TEST is true. Return the result of the last iteration, a la PROGN." + (let ((result-var (gensym))) + `(do (,result-var) ((not ,test) ,result-var) (setf ,result-var (progn ,@body))))) diff --git a/exports.lisp b/exports.lisp index 6aec7d6..54d4b35 100644 --- a/exports.lisp +++ b/exports.lisp @@ -1,7 +1,8 @@ (in-package #:syrup) +;; Support for inline and in-file symbol exports. (defvar *capture-exports* nil - "If non-nil, #^ doesn't export symbols. Either T, NIL, or the package to be monitored.") + "If non-nil, #^ won't export symbols, and will instead add to *exports*. Either T, NIL, or a specific package to monitor.") (defvar *exports* nil "List of captured symbol exports.") @@ -50,7 +51,7 @@ "Read Lisp source code from STREAM to determine the list of symbols it exports." (when target-package (let ((pkg (find-package target-package))) - (assert pkg () "No such package ~S" target-package) + (unless pkg (error "No such package: ~S" target-package)) (setf target-package pkg))) (let ((*package* *package*) (*readtable* *readtable*) @@ -60,15 +61,16 @@ (loop for form = (read stream nil eof-sentinel) until (eq form eof-sentinel) do (when (consp form) - (if (eql (car form) 'in-package) - (let ((pkg (find-package (cadr form)))) - (assert pkg () "No such package ~S" (cadr form)) - (setf *package* pkg) - (if (eq t *capture-exports*) - (setf *capture-exports* pkg))) - (when (and (eql (car form) 'export*) - (eq *package* *capture-exports*)) - (setf *exports* (nconc (mapcar #'ensure-symbol (cdr form)) *exports*)))))) + (case (car form) + (in-package + (let ((pkg (find-package (cadr form)))) + (unless pkg (error "No such package: ~S" (cadr form))) + (setf *package* pkg) + (when (eq t *capture-exports*) + (setf *capture-exports* pkg)))) + (export* + (when (eq *package* *capture-exports*) + (setf *exports* (nconc (mapcar #'ensure-symbol (cdr form)) *exports*))))))) *exports*)) (defmacro defpackage* (package-name &rest options) @@ -76,6 +78,8 @@ (let ((extra-exports nil) (pkg (find-package package-name))) (when pkg + ;; We're redefining the package, so let's scan the files we know about for exported symbols. + ;; This prevents them from being un-exported if the files are re-loaded out of order. (dolist (pathname (gethash pkg *package-files-table*)) (let ((exports (with-open-file (stream pathname :if-does-not-exist nil) (read-stream-for-exports stream pkg)))) diff --git a/syrup.asd b/syrup.asd index e705df2..144198a 100644 --- a/syrup.asd +++ b/syrup.asd @@ -1,9 +1,10 @@ (asdf:defsystem "syrup" :description "Assorted syntactic sugar for Lisp." - :version "1.0" + :version "1.1" :author "~keith " :homepage "https://bytes.keithhacks.cyou/keith/syrup" :license "Public Domain/CC0" :components ((:file "syrup") - (:file "exports")) + (:file "exports") + (:file "control-flow")) :serial t) diff --git a/syrup.lisp b/syrup.lisp index a2a6f46..ae34519 100644 --- a/syrup.lisp +++ b/syrup.lisp @@ -1,7 +1,12 @@ (defpackage #:syrup (:use #:cl) (:export - #:*capture-exports* #:*exports* #:export* #:defpackage* #:mark-package-file)) + #:simple-reader-error + ;; exports.lisp + #:export* #:defpackage* + ;; control-flow.lisp + #:if* #:while + )) (in-package #:syrup) (define-condition simple-reader-error (simple-condition reader-error) ())