/[cmucl]/src/code/extensions.lisp
ViewVC logotype

Diff of /src/code/extensions.lisp

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

revision 1.22.2.2 by pw, Sat Mar 23 18:49:58 2002 UTC revision 1.31 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 16  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
18    
19    (intl:textdomain "cmucl")
20    
21  (export '(letf* letf dovector deletef indenting-further file-comment  (export '(letf* letf dovector deletef indenting-further file-comment
22                  read-char-no-edit listen-skip-whitespace concat-pnames                  read-char-no-edit listen-skip-whitespace concat-pnames
23                  iterate once-only collect do-anonymous undefined-value                  iterate once-only collect do-anonymous undefined-value
# Line 45  Line 47 
47    called, it signals an error indicating that a required keyword argument was    called, it signals an error indicating that a required keyword argument was
48    not supplied.  This function is also useful for DEFSTRUCT slot defaults    not supplied.  This function is also useful for DEFSTRUCT slot defaults
49    corresponding to required arguments."    corresponding to required arguments."
50    (error "A required keyword argument was not supplied."))    (error (intl:gettext "A required keyword argument was not supplied.")))
51    
52    
53  ;;; FILE-COMMENT  --  Public  ;;; FILE-COMMENT  --  Public
# Line 172  Line 174 
174           ,setter))))           ,setter))))
175    
176    
177  (defmacro dovector ((elt vector) &rest forms)  (defmacro dovector ((elt vector &optional default) &rest forms)
178    "Just like dolist, but with one-dimensional arrays."    "Just like dolist, but with one-dimensional arrays."
179    (let ((index (gensym))    (let ((index (gensym))
180          (length (gensym))          (length (gensym))
# Line 180  Line 182 
182      `(let ((,vec ,vector))      `(let ((,vec ,vector))
183         (do ((,index 0 (1+ ,index))         (do ((,index 0 (1+ ,index))
184              (,length (length ,vec)))              (,length (length ,vec)))
185             ((>= ,index ,length) nil)             ((>= ,index ,length) ,default)
186           (let ((,elt (aref ,vec ,index)))           (let ((,elt (aref ,vec ,index)))
187             ,@forms)))))             ,@forms)))))
188    
# Line 207  Line 209 
209    (dolist (x binds)    (dolist (x binds)
210      (unless (and (listp x)      (unless (and (listp x)
211                   (= (length x) 2))                   (= (length x) 2))
212        (error "Malformed iterate variable spec: ~S." x)))        (error (intl:gettext "Malformed iterate variable spec: ~S.") x)))
213    
214    `(labels ((,name ,(mapcar #'first binds) ,@body))    `(labels ((,name ,(mapcar #'first binds) ,@body))
215       (,name ,@(mapcar #'second binds))))       (,name ,@(mapcar #'second binds))))
# Line 274  Line 276 
276          (binds ()))          (binds ()))
277      (dolist (spec collections)      (dolist (spec collections)
278        (unless (<= 1 (length spec) 3)        (unless (<= 1 (length spec) 3)
279          (error "Malformed collection specifier: ~S." spec))          (error (intl:gettext "Malformed collection specifier: ~S.") spec))
280        (let ((n-value (gensym))        (let ((n-value (gensym))
281              (name (first spec))              (name (first spec))
282              (default (second spec))              (default (second spec))
# Line 315  Line 317 
317          `(progn ,@body)          `(progn ,@body)
318          (let ((spec (first specs)))          (let ((spec (first specs)))
319            (when (/= (length spec) 2)            (when (/= (length spec) 2)
320              (error "Malformed Once-Only binding spec: ~S." spec))              (error (intl:gettext "Malformed Once-Only binding spec: ~S.") spec))
321            (let ((name (first spec))            (let ((name (first spec))
322                  (exp-temp (gensym)))                  (exp-temp (gensym)))
323              `(let ((,exp-temp ,(second spec))              `(let ((,exp-temp ,(second spec))
# Line 336  Line 338 
338           (l2 (gensym)))           (l2 (gensym)))
339      ;; Check for illegal old-style do.      ;; Check for illegal old-style do.
340      (when (or (not (listp varlist)) (atom endlist))      (when (or (not (listp varlist)) (atom endlist))
341        (error "Ill-formed ~S -- possibly illegal old style DO?" name))        (error (intl:gettext "Ill-formed ~S -- possibly illegal old style DO?") name))
342      ;; Parse the varlist to get inits and steps.      ;; Parse the varlist to get inits and steps.
343      (dolist (v varlist)      (dolist (v varlist)
344        (cond ((symbolp v) (push v inits))        (cond ((symbolp v) (push v inits))
345              ((listp v)              ((listp v)
346               (unless (symbolp (first v))               (unless (symbolp (first v))
347                 (error "~S step variable is not a symbol: ~S" name (first v)))                 (error (intl:gettext "~S step variable is not a symbol: ~S") name (first v)))
348               (case (length v)               (case (length v)
349                 (1 (push (first v) inits))                 (1 (push (first v) inits))
350                 (2 (push v inits))                 (2 (push v inits))
351                 (3 (push (list (first v) (second v)) inits)                 (3 (push (list (first v) (second v)) inits)
352                    (setq steps (list* (third v) (first v) steps)))                    (setq steps (list* (third v) (first v) steps)))
353                 (t (error "~S is an illegal form for a ~S varlist." v name))))                 (t (error (intl:gettext "~S is an illegal form for a ~S varlist.") v name))))
354              (t (error "~S is an illegal form for a ~S varlist." v name))))              (t (error (intl:gettext "~S is an illegal form for a ~S varlist.") v name))))
355      ;; And finally construct the new form.      ;; And finally construct the new form.
356      `(block ,BLOCK      `(block ,BLOCK
357         (,bind ,(nreverse inits)         (,bind ,(nreverse inits)
# Line 364  Line 366 
366           (return-from ,BLOCK (progn ,@(cdr endlist))))))))           (return-from ,BLOCK (progn ,@(cdr endlist))))))))
367    
368    
369  (defmacro do-anonymous (varlist endlist &body (body decls))  (defmacro do-anonymous (varlist endlist &parse-body (body decls))
370    "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*    "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
371    Like DO, but has no implicit NIL block.  Each Var is initialized in parallel    Like DO, but has no implicit NIL block.  Each Var is initialized in parallel
372    to the value of the specified Init form.  On subsequent iterations, the Vars    to the value of the specified Init form.  On subsequent iterations, the Vars
# Line 376  Line 378 
378                      'do-anonymous (gensym)))                      'do-anonymous (gensym)))
379    
380  (defmacro do-hash ((key-var value-var table &optional result)  (defmacro do-hash ((key-var value-var table &optional result)
381                     &body (body decls))                     &parse-body (body decls))
382    "DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form*    "DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form*
383     Iterate over the entries in a hash-table."     Iterate over the entries in a hash-table."
384    (let ((gen (gensym))    (let ((gen (gensym))
# Line 456  Line 458 
458           (n-cache (gensym)))           (n-cache (gensym)))
459    
460      (unless (= (length default-values) values)      (unless (= (length default-values) values)
461        (error "Number of default values ~S differs from :VALUES ~D."        (error (intl:gettext "Number of default values ~S differs from :VALUES ~D.")
462               default values))               default values))
463    
464      (collect ((inlines)      (collect ((inlines)
# Line 474  Line 476 
476        (let ((n 0))        (let ((n 0))
477          (dolist (arg args)          (dolist (arg args)
478            (unless (= (length arg) 2)            (unless (= (length arg) 2)
479              (error "Bad arg spec: ~S." arg))              (error (intl:gettext "Bad arg spec: ~S.") arg))
480            (let ((arg-name (first arg))            (let ((arg-name (first arg))
481                  (test (second arg)))                  (test (second arg)))
482              (arg-vars arg-name)              (arg-vars arg-name)
# Line 484  Line 486 
486              (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name)))              (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name)))
487                (forms                (forms
488                 `(defun ,fun-name (,arg-name)                 `(defun ,fun-name (,arg-name)
489                    (do ((,n-index ,(+ (- total-size entry-size) n)                    (sys:without-interrupts
490                                   (- ,n-index ,entry-size))                     (do ((,n-index ,(+ (- total-size entry-size) n)
491                         (,n-cache ,var-name))                                    (- ,n-index ,entry-size))
492                        ((minusp ,n-index))                          (,n-cache ,var-name))
493                      (declare (type fixnum ,n-index))                         ((minusp ,n-index))
494                      (when (,test (svref ,n-cache ,n-index) ,arg-name)                       (declare (type fixnum ,n-index))
495                        (let ((,n-index (- ,n-index ,n)))                       (when (,test (svref ,n-cache ,n-index) ,arg-name)
496                          ,@(mapcar #'(lambda (i val)                         (let ((,n-index (- ,n-index ,n)))
497                                        `(setf (svref ,n-cache ,i) ,val))                           ,@(mapcar #'(lambda (i val)
498                                    (values-indices)                                         `(setf (svref ,n-cache ,i) ,val))
499                                    default-values))))                                     (values-indices)
500                    (undefined-value)))))                                     default-values))))
501                      (values))))))
502            (incf n)))            (incf n)))
503    
504        (when *profile-hash-cache*        (when *profile-hash-cache*
# Line 511  Line 514 
514          (inlines fun-name)          (inlines fun-name)
515          (forms          (forms
516           `(defun ,fun-name ,(arg-vars)           `(defun ,fun-name ,(arg-vars)
517              ,@(when *profile-hash-cache*              (sys:without-interrupts
518                  `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))               ,@(when *profile-hash-cache*
519              (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))                   `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
520                    (,n-cache ,var-name))               (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
521                (declare (type fixnum ,n-index))                     (,n-cache ,var-name))
522                (cond ((and ,@(tests))                 (declare (type fixnum ,n-index))
523                       (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))                 (cond ((and ,@(tests))
524                                         (values-indices))))                        (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))
525                      (t                                          (values-indices))))
526                       ,@(when *profile-hash-cache*                       (t
527                           `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))                        ,@(when *profile-hash-cache*
528                       ,default))))))                            `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
529                          ,default)))))))
530    
531        (let ((fun-name (symbolicate name "-CACHE-ENTER")))        (let ((fun-name (symbolicate name "-CACHE-ENTER")))
532          (inlines fun-name)          (inlines fun-name)
533          (forms          (forms
534           `(defun ,fun-name (,@(arg-vars) ,@(values-names))           `(defun ,fun-name (,@(arg-vars) ,@(values-names))
535              (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))              (sys:without-interrupts
536                    (,n-cache ,var-name))               (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
537                (declare (type fixnum ,n-index))                     (,n-cache ,var-name))
538                ,@(sets)                 (declare (type fixnum ,n-index))
539                ,@(mapcar #'(lambda (i val)                 ,@(sets)
540                              `(setf (svref ,n-cache ,i) ,val))                 ,@(mapcar #'(lambda (i val)
541                          (values-indices)                               `(setf (svref ,n-cache ,i) ,val))
542                          (values-names))                           (values-indices)
543                (undefined-value)))))                           (values-names))
544                   (values))))))
545    
546        (let ((fun-name (symbolicate name "-CACHE-CLEAR")))        (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
547          (forms          (forms
548           `(defun ,fun-name ()           `(defun ,fun-name ()
549              (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))              (sys:without-interrupts
550                   (,n-cache ,var-name))               (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
551                  ((minusp ,n-index))                    (,n-cache ,var-name))
552                (declare (type fixnum ,n-index))                   ((minusp ,n-index))
553                ,@(collect ((arg-sets))                 (declare (type fixnum ,n-index))
554                    (dotimes (i nargs)                 ,@(collect ((arg-sets))
555                      (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))                     (dotimes (i nargs)
556                    (arg-sets))                       (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
557                ,@(mapcar #'(lambda (i val)                     (arg-sets))
558                              `(setf (svref ,n-cache ,i) ,val))                 ,@(mapcar #'(lambda (i val)
559                          (values-indices)                               `(setf (svref ,n-cache ,i) ,val))
560                          default-values))                           (values-indices)
561              (undefined-value)))                           default-values))
562                (values))))
563          (forms `(,fun-name)))          (forms `(,fun-name)))
564    
565        (inits `(unless (boundp ',var-name)        (inits `(unless (boundp ',var-name)
# Line 572  Line 578 
578  ;;;  ;;;
579  (defmacro defun-cached ((name &rest options &key (values 1) default  (defmacro defun-cached ((name &rest options &key (values 1) default
580                                &allow-other-keys)                                &allow-other-keys)
581                          args &body (body decls doc))                          args &parse-body (body decls doc))
582    "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*    "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
583    Some syntactic sugar for defining a function whose values are cached by    Some syntactic sugar for defining a function whose values are cached by
584    DEFINE-HASH-CACHE."    DEFINE-HASH-CACHE."
585    (let ((default-values (if (and (consp default) (eq (car default) 'values))    (let ((default-values (if (and (consp default) (eq (car default) 'values))
586                              (cdr default)                              (cdr default)
587                              (list default)))                              (list default)))
588          (arg-names (mapcar #'car args)))          (arg-names (mapcar #'car args))
589      (collect ((values-names))          (values-names (loop repeat values collect (gensym)))
590        (dotimes (i values)          (cache-lookup (symbolicate name "-CACHE-LOOKUP"))
591          (values-names (gensym)))          (cache-enter (symbolicate name "-CACHE-ENTER")))
592        `(progn        `(progn
593           (define-hash-cache ,name ,args ,@options)           (define-hash-cache ,name ,args ,@options)
594           (defun ,name ,arg-names           (defun ,name ,arg-names
595             ,@decls             ,@decls
596             ,doc             ,doc
597             (multiple-value-bind             (multiple-value-bind ,values-names
598                 ,(values-names)                 (,cache-lookup ,@arg-names)
599                 (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)               (if (and ,@(mapcar (lambda (val def) `(eq ,val ,def))
600               (if (and ,@(mapcar #'(lambda (val def)                                  values-names
601                                      `(eq ,val ,def))                                  default-values))
602                                  (values-names) default-values))                   (multiple-value-bind ,values-names
603                   (multiple-value-bind ,(values-names)                       (progn ,@body)
604                                        (progn ,@body)                     (,cache-enter ,@arg-names ,@values-names)
605                     (,(symbolicate name "-CACHE-ENTER") ,@arg-names                     (values ,@values-names))
606                      ,@(values-names))                   (values ,@values-names)))))))
                    (values ,@(values-names)))  
                  (values ,@(values-names)))))))))  
607    
608    
609  ;;; CACHE-HASH-EQ  -- Public  ;;; CACHE-HASH-EQ  -- Public

Legend:
Removed from v.1.22.2.2  
changed lines
  Added in v.1.31

  ViewVC Help
Powered by ViewVC 1.1.5