/[gcl]/gcl/pcl/pcl_fngen.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_fngen.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Wed Feb 26 22:21:41 2003 UTC revision 1.2 by camm, Thu Oct 23 15:19:32 2003 UTC
# Line 147  Line 147 
147    (let ((walk-form-expand-macros-p t))    (let ((walk-form-expand-macros-p t))
148      (walk-form lambda      (walk-form lambda
149                 nil                 nil
150                 #'(lambda (f c e)                 (lambda (f c e)
151                     (declare (ignore e))                     (declare (ignore e))
152                     (if (neq c :eval)                     (if (neq c :eval)
153                         f                         f
# Line 159  Line 159 
159          (gensyms ()))          (gensyms ()))
160      (values (walk-form lambda      (values (walk-form lambda
161                         nil                         nil
162                         #'(lambda (f c e)                         (lambda (f c e)
163                             (declare (ignore e))                             (declare (ignore e))
164                             (if (neq c :eval)                             (if (neq c :eval)
165                                 f                                 f
# Line 170  Line 170 
170                gensyms)))                gensyms)))
171    
172  (defun compute-constants (lambda constant-converter)  (defun compute-constants (lambda constant-converter)
173    (let ((walk-form-expand-macros-p t)) ; doesn't matter here.    (let ((walk-form-expand-macros-p t) ; doesn't matter here.
174      (macrolet ((appending ()          (collected ()))
175                   `(let ((result ()))      (walk-form lambda
176                     (values #'(lambda (value) (setq result (append result value)))                 nil
177                      #'(lambda ()result)))))                 (lambda (f c e)
178        (gathering1 (appending)                     (declare (ignore e))
179                    (walk-form lambda                     (if (eq c :eval)
180                               nil                         (let ((consts (funcall constant-converter f)))
181                               #'(lambda (f c e)                           (if consts
182                                   (declare (ignore e))                               (progn
183                                   (if (neq c :eval)                                 (setq collected (append collected consts))
184                                       f                                 (values f t))
185                                       (let ((consts (funcall constant-converter f)))                             f))
186                                         (if consts                       f)))
187                                             (progn (gather1 consts) (values f t))      collected))
                                            f)))))))))  
   
   
188  ;;;  ;;;
189  ;;;  ;;;
190  ;;;  ;;;
191  (defmacro precompile-function-generators (&optional system)  (defmacro precompile-function-generators (&optional system)
192    (let ((index -1))    (let ((index -1))
193      `(progn ,@(gathering1 (collecting)      `(progn ,@(let ((collected ()))
194                  (dolist (fgen *fgens*)                  (dolist (fgen *fgens* (nreverse collected))
195                    (when (or (null (fgen-system fgen))                    (when (or (null (fgen-system fgen))
196                              (eq (fgen-system fgen) system))                              (eq (fgen-system fgen) system))
197                      (when system (setf (svref fgen 4) system))                      (when system
198                      (gather1                        (setf (svref fgen 4) system))
199                        (push
200                       (make-top-level-form                       (make-top-level-form
201                        `(precompile-function-generators ,system ,(incf index))                        `(precompile-function-generators ,system ,(incf index))
202                        '(load)                        '(load)
# Line 207  Line 205 
205                          ',(fgen-gensyms fgen)                          ',(fgen-gensyms fgen)
206                          (function ,(fgen-generator-lambda fgen))                          (function ,(fgen-generator-lambda fgen))
207                          ',(fgen-generator-lambda fgen)                          ',(fgen-generator-lambda fgen)
208                          ',system)))))))))                          ',system))
209                         collected)))))))
210    
211  (defun load-function-generator (test gensyms generator generator-lambda system)  (defun load-function-generator (test gensyms generator generator-lambda system)
212    (store-fgen (make-fgen test gensyms generator generator-lambda system)))    (store-fgen (make-fgen test gensyms generator generator-lambda system)))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26