--- a/beast.lisp Tue Aug 09 19:14:27 2016 +0000
+++ b/beast.lisp Tue Aug 09 20:45:20 2016 +0000
@@ -164,46 +164,58 @@
:collect (make-hash-table))))
-(defmacro define-system (name arglist &body body)
- (flet ((system-type-signature (arglist)
- `(function (,@(mapcar (lambda (arg)
- `(and entity ,@(cdr arg)))
- arglist))
- (values null &optional))))
- `(progn
- (declaim (ftype ,(system-type-signature arglist) ,name))
- (defun ,name (,@(mapcar #'car arglist))
- ,@body
- nil)
+(defun build-system-runner-1 (name type-specifiers)
+ (with-gensyms (argument-indexes entity)
+ `(let ((,argument-indexes (gethash ',name *system-index*)))
+ (loop :for ,entity :being :the hash-values :of (first ,argument-indexes)
+ :do (locally
+ (declare (type ,(first type-specifiers) ,entity))
+ (,name ,entity))))))
- (initialize-system-index ',name #',name ',arglist)
+(defun build-system-runner-2 (name type-specifiers)
+ (with-gensyms (argument-indexes e1 e2)
+ `(let ((,argument-indexes (gethash ',name *system-index*)))
+ (loop
+ :for ,e1 :being :the hash-values :of (first ,argument-indexes)
+ :do (loop :for ,e2 :being :the hash-values :of (second ,argument-indexes)
+ :do (locally
+ (declare (type ,(first type-specifiers) ,e1)
+ (type ,(second type-specifiers) ,e2))
+ (,name ,e1 ,e2)))))))
- ',name)))
+(defun build-system-runner-n (name)
+ `(apply #'map-product #',name
+ (mapcar #'hash-table-values (gethash ',name *system-index*))))
-(defun run-system-fast-1 (system system-function)
- (let ((argument-indexes (gethash system *system-index*)))
- (loop :for entity :being :the hash-values :of (first argument-indexes)
- :do (funcall system-function entity))))
-
-(defun run-system-fast-2 (system system-function)
- (let ((argument-indexes (gethash system *system-index*)))
- (loop
- :for e1 :being :the hash-values :of (first argument-indexes)
- :do (loop :for e2 :being :the hash-values :of (second argument-indexes)
- :do (funcall system-function e1 e2)))))
+(defun build-system-runner (name arity type-specifiers)
+ (case arity
+ (0 nil)
+ (1 (build-system-runner-1 name type-specifiers))
+ (2 (build-system-runner-2 name type-specifiers))
+ (t (build-system-runner-n name))))
-(defun run-system (system)
- (destructuring-bind (system-function arity type-specifiers)
- (gethash system *systems*)
- (declare (ignore type-specifiers))
- (case arity
- ;; Special-case systems of arity 1/2 for speed
- (0 nil)
- (1 (run-system-fast-1 system system-function))
- (2 (run-system-fast-2 system system-function))
- (t (apply #'map-product system-function
- (mapcar #'hash-table-values (gethash system *system-index*)))))
- (values)))
+(defmacro define-system (name-and-options arglist &body body)
+ (let ((argument-type-specifiers (loop :for arg :in arglist
+ :collect `(and entity ,@(cdr arg)))))
+ (destructuring-bind (name &key inline)
+ (ensure-list name-and-options)
+ `(progn
+ (declaim (ftype (function (,@argument-type-specifiers)
+ (values null &optional))
+ ,name)
+ ,(if inline
+ `(inline ,name)
+ `(notinline ,name)))
+ (defun ,name (,@(mapcar #'car arglist))
+ ,@body
+ nil)
+ (defun ,(symb 'run- name) ()
+ ,(build-system-runner name (length arglist) argument-type-specifiers))
+
+ (initialize-system-index ',name #',name ',arglist)
+
+ ',name))))
+
--- a/quickutils.lisp Tue Aug 09 19:14:27 2016 +0000
+++ b/quickutils.lisp Tue Aug 09 20:45:20 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:MAP-PRODUCT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-VALUES :SYMB :ENSURE-KEYWORD) :ensure-package T :package "BEAST.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:MAP-PRODUCT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-VALUES :WITH-GENSYMS :SYMB :ENSURE-KEYWORD :ENSURE-LIST) :ensure-package T :package "BEAST.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BEAST.QUICKUTILS")
@@ -17,7 +17,9 @@
:CURRY :MAPPEND :MAP-PRODUCT
:HASH-TABLE-KEY-EXISTS-P
:MAPHASH-VALUES :HASH-TABLE-VALUES
- :MKSTR :SYMB :ENSURE-KEYWORD))))
+ :STRING-DESIGNATOR :WITH-GENSYMS
+ :MKSTR :SYMB :ENSURE-KEYWORD
+ :ENSURE-LIST))))
(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`,
@@ -113,6 +115,50 @@
values))
+ (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))
+
+
(defun mkstr (&rest args)
"Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
@@ -134,8 +180,15 @@
"Ensure that a keyword is returned for the string designator `x`."
(values (intern (string x) :keyword)))
+
+ (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)))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(map-product hash-table-key-exists-p hash-table-values symb
- ensure-keyword)))
+ (export '(map-product hash-table-key-exists-p hash-table-values with-gensyms
+ with-unique-names symb ensure-keyword ensure-list)))
;;;; END OF quickutils.lisp ;;;;