939570d22350

Refactor the system running into actual functions
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 09 Aug 2016 20:45:20 +0000
parents 73e5c322e496
children e6e8c6e2ef91
branches/tags (none)
files beast.lisp make-quickutils.lisp quickutils.lisp

Changes

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 ;;;;