# HG changeset patch # User Steve Losh # Date 1470775520 0 # Node ID 939570d22350b97f1c4136af8c532ddd0bd23931 # Parent 73e5c322e4964bd4c09bc1fba6a39c7d038b7ad3 Refactor the system running into actual functions diff -r 73e5c322e496 -r 939570d22350 beast.lisp --- 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)))) + diff -r 73e5c322e496 -r 939570d22350 make-quickutils.lisp --- a/make-quickutils.lisp Tue Aug 09 19:14:27 2016 +0000 +++ b/make-quickutils.lisp Tue Aug 09 20:45:20 2016 +0000 @@ -5,6 +5,8 @@ :utilities '(:map-product :hash-table-key-exists-p :hash-table-values + :with-gensyms :symb - :ensure-keyword) + :ensure-keyword + :ensure-list) :package "BEAST.QUICKUTILS") diff -r 73e5c322e496 -r 939570d22350 quickutils.lisp --- 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 ;;;;