Changeset 2327


Ignore:
Timestamp:
Aug 20, 2005, 8:06:25 PM (14 years ago)
Author:
bryan
Message:

remove all reader-conditionalized code for non-openmcl platforms.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/library/loop.lisp

    r929 r2327  
    6363;;;; LOOP Iteration Macro
    6464
    65 #+CCL-2
    6665(defpackage ANSI-LOOP (:use "COMMON-LISP"))
    6766
    6867(in-package :ansi-loop)
    69 
    70 #+Cloe-Runtime                                  ;Don't ask.
    71 (car (push "%Z% %M% %I% %E% %U%" system::*module-identifications*))
    7268
    7369;;; Technology.
     
    124120;;;; Miscellaneous Environment Things
    125121
    126 
    127 
    128 ;;;@@@@The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or
    129 ;;; its obvious expansion (prog1 (car x) (setq x (cdr x))).  Usually this involves
    130 ;;; shifting fenceposts in an iteration or series of carcdr operations.  This is
    131 ;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's
    132 ;;; destructuring setq code.
    133 (eval-when (compile load eval)
    134   #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*)
    135   )
    136 
    137 
    138122;;; The uses of this macro are retained in the CL version of loop, in
    139123;;; case they are needed in a particular implementation.  Originally
     
    143127;;; probably be RPLACDed and so cdr-normal should be used instead.
    144128(defmacro loop-copylist* (l)
    145   #+Genera `(lisp:copy-list ,l nil t)           ; arglist = (list &optional area force-dotted)
    146   ;;@@@@Explorer??
    147   #-Genera `(copy-list ,l)
    148   )
    149 
     129  `(copy-list ,l))
    150130
    151131(defvar *loop-gentemp*
     
    157137      (gensym (string pref))))
    158138
    159 
    160 
    161139(defvar *loop-real-data-type* 'real)
    162 
    163140
    164141(defun loop-optimization-quantities (env)
     
    169146  ;; replaced with the appropriate conditional name for your
    170147  ;; implementation/dialect.
    171   (declare #-(or ANSI CCL-2) (ignore env)
    172            #+Genera (values speed space safety compilation-speed debug))
    173   #+(or ANSI CCL-2)
    174148  ;; Uhh, DECLARATION-INFORMATION isn't ANSI-CL anymore
    175   (let ((stuff (#+openmcl
    176                 ccl:declaration-information
    177                 #-openmcl
    178                 declaration-information
    179                 'optimize env)))
    180     (values (or (#+CCL-2 cadr #-CCL-2 cdr (assoc 'speed stuff)) 1)
    181                    (or (#+CCL-2 cadr #-CCL-2 cdr (assoc 'space stuff)) 1)
    182                    (or (#+CCL-2 cadr #-CCL-2 cdr (assoc 'safety stuff)) 1)
    183                    (or (#+CCL-2 cadr #-CCL-2 cdr (assoc 'compilation-speed stuff)) 1)
    184                    (or (#+CCL-2 cadr #-CCL-2 cdr (assoc 'debug stuff)) 1)))
    185   #+CLOE-Runtime (values compiler::time compiler::space
    186                          compiler::safety compiler::compilation-speed 1)
    187   #-(or ANSI CCL-2 CLOE-Runtime) (values 1 1 1 1 1))
     149  (let ((stuff (ccl:declaration-information 'optimize env)))
     150    (values (or (cadr (assoc 'speed stuff)) 1)
     151            (or (cadr (assoc 'space stuff)) 1)
     152            (or (cadr (assoc 'safety stuff)) 1)
     153            (or (cadr (assoc 'compilation-speed stuff)) 1)
     154            (or (cadr (assoc 'debug stuff)) 1))))
    188155
    189156
     
    198165;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
    199166(defun hide-variable-references (variable-list form)
    200   (declare #-Genera (ignore variable-list))
    201   #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form)
    202   #-Genera form)
    203 
     167  (declare (ignore variable-list))
     168  form)
    204169
    205170;;;@@@@ The following function takes a flag, a variable, and a form which presumably
     
    222187;;; for all callers to contain the conditional invisibility construction.
    223188(defun hide-variable-reference (really-hide variable form)
    224   (declare #-Genera (ignore really-hide variable))
    225   #+Genera (if (and really-hide variable (atom variable))       ;Punt on destructuring patterns
    226                `(compiler:invisible-references (,variable) ,form)
    227                form)
    228   #-Genera form)
     189  (declare (ignore really-hide variable))
     190  form)
    229191
    230192
     
    235197(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var)
    236198                                          &body body)
    237   ;;@@@@ TI? Exploder?
    238   #+LISPM (let ((head-place (or user-head-var head-var)))
    239             `(let* ((,head-place nil)
    240                     (,tail-var
    241                       ,(hide-variable-reference
    242                          user-head-var user-head-var
    243                          `(progn #+Genera (scl:locf ,head-place)
    244                                  #-Genera (system:variable-location ,head-place)))))
    245                ,@body))
    246   #-LISPM (let ((l (and user-head-var (list (list user-head-var nil)))))
    247             #+CLOE `(sys::with-stack-list* (,head-var nil nil)
    248                       (let ((,tail-var ,head-var) ,@l)
    249                         ,@body))
    250             #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
    251                       ,@body)))
     199  (let ((l (and user-head-var (list (list user-head-var nil)))))
     200    `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
     201       ,@body)))
    252202
    253203
    254204(defmacro loop-collect-rplacd (&environment env
    255205                               (head-var tail-var &optional user-head-var) form)
    256   (declare
    257     #+LISPM (ignore head-var user-head-var)     ;use locatives, unconditionally update through the tail.
    258     )
    259206  (setq form (macroexpand form env))
    260207  (flet ((cdr-wrap (form n)
     
    276223               ;; cdr-nil at the end (which would just force copying
    277224               ;; the whole list again).
    278                #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
     225               )
    279226              ((member (car form) '(list* cons))
    280227               (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
     
    296243        ;; head variable, we've got to set it...  It's harmless to repeatedly set it
    297244        ;; unconditionally, and probably faster than checking.
    298         #-LISPM (when user-head-var
    299                   (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
     245        (when user-head-var
     246          (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
    300247        answer))))
    301248
     
    307254        ;; then the head var itself contains the answer.  Otherwise we
    308255        ;; have to cdr it.
    309         #+LISPM head-var
    310         #-LISPM `(cdr ,head-var))))
     256        `(cdr ,head-var))))
    311257
    312258
     
    343289
    344290(defvar *loop-minimax-type-infinities-alist*
    345         ;;@@@@ This is the sort of value this should take on for a Lisp that has
    346         ;; "eminently usable" infinities.  n.b. there are neither constants nor
    347         ;; printed representations for infinities defined by CL.
    348         ;;@@@@ This grotesque read-from-string below is to help implementations
    349         ;; which croak on the infinity character when it appears in a token, even
    350         ;; conditionalized out.
    351         #+Genera
    352           '#.(read-from-string
    353               "((fixnum         most-positive-fixnum     most-negative-fixnum)
    354                 (short-float    +1s                     -1s)
    355                 (single-float   +1f                     -1f)
    356                 (double-float   +1d                     -1d)
    357                 (long-float     +1l                     -1l))")
    358         ;;This is how the alist should look for a lisp that has no infinities.  In
    359         ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
    360         #+(or CLOE-Runtime Minima)
    361           '((fixnum             most-positive-fixnum            most-negative-fixnum)
    362             (short-float        most-positive-short-float       most-negative-short-float)
    363             (single-float       most-positive-single-float      most-negative-single-float)
    364             (double-float       most-positive-double-float      most-negative-double-float)
    365             (long-float         most-positive-long-float        most-negative-long-float))
    366         ;;If we don't know, then we cannot provide "infinite" initial values for any of the
    367         ;; types but FIXNUM:
    368         #-(or Genera CLOE-Runtime Minima)
    369           '((fixnum             most-positive-fixnum            most-negative-fixnum))
    370           )
     291  '((fixnum             most-positive-fixnum            most-negative-fixnum))
     292  )
    371293
    372294
     
    492414               (:extended "Extended-ANSI")
    493415               (t (loop-universe-ansi u)))))
    494     ;;Cloe could be done with the above except for bootstrap lossage...
    495     #+CLOE
    496     (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u))
    497     #-CLOE
    498416    (print-unreadable-object (u stream :type t :identity t)
    499417      (princ str stream))))
     
    507425(defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords
    508426                                    type-keywords type-symbols ansi)
    509   #-(and CLOE Source-Bootstrap) (check-type ansi (member nil t :extended))
     427  (check-type ansi (member nil t :extended))
    510428  (flet ((maketable (entries)
    511429           (let* ((size (length entries))
     
    593511                         (let* ((temp-p temp)
    594512                                (temp (or temp *loop-desetq-temporary*))
    595                                 (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
    596                                                               car
    597                                                               `(prog1 (car ,temp)
    598                                                                       (setq ,temp (cdr ,temp))))
    599                                                           ,@(loop-desetq-internal cdr temp temp))
    600                                       #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
    601                                                           (setq ,temp (cdr ,temp))
    602                                                           ,@(loop-desetq-internal cdr temp temp))))
     513                                (body  `(,@(loop-desetq-internal car `(car ,temp))
     514                                           (setq ,temp (cdr ,temp))
     515                                           ,@(loop-desetq-internal cdr temp temp))))
    603516                           (if temp-p
    604517                               `(,@(unless (eq temp val)
     
    738651
    739652(defun loop-constant-fold-if-possible (form &optional expected-type)
    740   #+Genera (declare (values new-form constantp constant-value))
    741653  (let ((new-form form) (constantp nil) (constant-value nil))
    742     #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment*
    743                                                     :repeat t
    744                                                     :do-macro-expansion t
    745                                                     :do-named-constants t
    746                                                     :do-inline-forms t
    747                                                     :do-optimizers t
    748                                                     :do-constant-folding t
    749                                                     :do-function-args t)
    750                    constantp (constantp new-form *loop-macro-environment*)
    751                    constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
    752     #-Genera (when (setq constantp (constantp new-form))
    753                (setq constant-value (eval new-form)))
     654    (when (setq constantp (constantp new-form))
     655      (setq constant-value (eval new-form)))
    754656    (when (and constantp expected-type)
    755657      (unless (typep constant-value expected-type)
    756658        (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
    757                    form constant-value expected-type)
     659          form constant-value expected-type)
    758660        (setq constantp nil constant-value nil)))
    759661    (values new-form constantp constant-value)))
     
    761663
    762664(defun loop-constantp (form)
    763   #+Genera (constantp form *loop-macro-environment*)
    764   #-Genera (constantp form))
     665  (constantp form))
    765666
    766667
     
    912813             (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
    913814    ;;@@@@ ???? (declare (function list-size (list) fixnum))
    914     (cond ((constantp x #+Genera env) 1)
     815    (cond ((constantp x) 1)
    915816          ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
    916817                         (if expanded-p (estimate-code-size-1 new-form env) 1)))
     
    927828                        (t (funcall tem x env))))
    928829                     ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
    929                      #+Genera
    930                      ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
    931                      ((eq fn 'cond)
     830                     ((eq fn 'cond)
    932831                      (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
    933832                     ((eq fn 'desetq)
     
    966865
    967866(defun loop-error (format-string &rest format-args)
    968   #+(or Genera CLOE) (declare (dbg:error-reporter))
    969   #+Genera (setq format-args (copy-list format-args))   ;Don't ask.
    970   (#+mcl ccl::signal-program-error #-mcl error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
     867  (ccl::signal-program-error "~?~%Current LOOP context:~{ ~S~}."
     868                             format-string format-args (loop-context)))
    971869
    972870
     
    11441042
    11451043(defun loop-disallow-conditional (&optional kwd)
    1146   #+(or Genera CLOE) (declare (dbg:error-reporter))
    11471044  (when *loop-inside-conditional*
    11481045    (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
     
    12721169                    ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
    12731170                    (setq *loop-desetq-crocks*
    1274                       (list* name newvar *loop-desetq-crocks*))
    1275                     #+ignore
    1276                     (loop-make-variable name nil dtype iteration-variable-p)))))
     1171                      (list* name newvar *loop-desetq-crocks*))))))
    12771172        (t (let ((tcar nil) (tcdr nil))
    12781173             (if (atom dtype) (setq tcar (setq tcdr dtype))
     
    16381533      ;; return: (3 3) or (4 3)? PUSHes above are for the former
    16391534      ;; variant, L-P-B below for the latter.
    1640       #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
     1535      )))
    16411536
    16421537(defun loop-when-it-variable ()
     
    16771572            (cadr vector-form)
    16781573            'vector))
    1679       #+Genera (push `(system:array-register ,vector-var) *loop-declarations*)
    16801574      (loop-make-variable index-var 0 'fixnum)
    16811575      (let* ((length 0)
     
    17301624               (loop-make-iteration-variable var nil data-type)))
    17311625      (multiple-value-bind (list-step step-function) (loop-list-step listvar)
    1732         (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
     1626        (declare (ignore step-function))
    17331627        ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
    17341628        (let* ((first-endtest
     
    17461640                 `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
    17471641                   () () () ,first-endtest ()))
    1748                 #+LOOP-Prefer-POP
    1749                 ((and step-function
    1750                       (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
    1751                                                            (cdddr . 3) (cddddr . 4))))))
    1752                         (and n (do ((l var (cdr l)) (i 0 (1+ i)))
    1753                                    ((atom l) (and (null l) (= i n)))
    1754                                  (declare (fixnum i))))))
    1755                  (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
    1756                    `(,other-endtest () () ,step ,first-endtest () () ,step)))
    17571642                (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
    17581643                     `(,other-endtest ,step () ,pseudo
     
    17671652      (loop-make-variable listvar list 'list)
    17681653      (multiple-value-bind (list-step step-function) (loop-list-step listvar)
    1769         #-LOOP-Prefer-POP (declare (ignore step-function))
     1654        (declare (ignore step-function))
    17701655        (let* ((first-endtest `(endp ,listvar))
    17711656               (other-endtest first-endtest)
     
    17741659          (when (and constantp (listp list-value))
    17751660            (setq first-endtest (null list-value)))
    1776           #+LOOP-Prefer-POP (when (eq step-function 'cdr)
    1777                               (setq step `(,var (pop ,listvar)) pseudo-step nil))
    17781661          `(,other-endtest ,step () ,pseudo-step
    17791662            ,@(and (not (eq first-endtest other-endtest))
     
    17981681  (unless (listp names) (setq names (list names)))
    17991682  ;; Can't do this due to CLOS bootstrapping problems.
    1800   #-(or Genera (and CLOE Source-Bootstrap)) (check-type universe loop-universe)
     1683  (check-type universe loop-universe)
    18011684  (let ((ht (loop-universe-path-keywords universe))
    18021685        (lp (make-loop-path
     
    20351918  (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
    20361919    (let ((sequencev (named-variable 'sequence)))
    2037       #+Genera (when (and sequencev
    2038                           (symbolp sequencev)
    2039                           sequence-type
    2040                           (subtypep sequence-type 'vector)
    2041                           (not (member (the symbol sequencev) *loop-nodeclare*)))
    2042                  (push `(sys:array-register ,sequencev) *loop-declarations*))
    20431920      (list* nil nil                            ; dummy bindings and prologue
    20441921             (loop-sequencer
     
    20751952      ;; specified, so clever code can throw away the gensym'ed up variable if
    20761953      ;; it isn't really needed.
    2077       #+ccl-2 (unless other-p (push `(ignorable ,other-var) *loop-declarations*))
     1954      (unless other-p (push `(ignorable ,other-var) *loop-declarations*))
    20781955      ;;The following is for those implementations in which we cannot put dummy NILs
    20791956      ;; into multiple-value-setq variable lists.
    2080       #-Genera (setq other-p t
    2081                      dummy-predicate-var (loop-when-it-variable))
     1957      (setq other-p t
     1958            dummy-predicate-var (loop-when-it-variable))
    20821959      (setq variable (or variable (loop-gentemp 'ignore-)))
    20831960      (let ((key-var nil)
     
    20981975                             ,@post-steps))
    20991976          (push `(,val-var nil) bindings))
    2100         #+ccl-2 (push `(ignorable ,dummy-predicate-var) *loop-declarations*)
     1977        (push `(ignorable ,dummy-predicate-var) *loop-declarations*)
    21011978        `(,bindings                             ;bindings
    21021979          ()                                    ;prologue
     
    21191996        (pkg (or (cadar prep-phrases) '*package*)))
    21201997    (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
    2121     #+ccl-2 (push `(ignorable ,(loop-when-it-variable)) *loop-declarations*)
     1998    (push `(ignorable ,(loop-when-it-variable)) *loop-declarations*)
    21221999   
    21232000    `(((,variable nil ,data-type) (,pkg-var ,pkg))
     
    21282005                                    ;;@@@@ If an implementation can get away without actually
    21292006                                    ;; using a variable here, so much the better.
    2130                                     #+Genera NIL
    2131                                     #-Genera (loop-when-it-variable))
     2007                                    (loop-when-it-variable))
    21322008                                 ,variable)
    21332009             (,next-fn)))
     
    22302106
    22312107
    2232 #+ccl-2
    22332108(fmakunbound 'loop)                     ; Avoid redefinition warning
    22342109
    22352110;;;INTERFACE: ANSI
    22362111(defmacro loop (&environment env &rest keywords-and-forms)
    2237   #+Genera (declare (compiler:do-not-record-macroexpansions)
    2238                     (zwei:indentation . zwei:indent-loop))
    22392112  (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
    22402113
    2241 #+ccl-2
    22422114(cl:provide "LOOP")
Note: See TracChangeset for help on using the changeset viewer.