Changeset 12301


Ignore:
Timestamp:
Jun 25, 2009, 4:57:58 PM (10 years ago)
Author:
gz
Message:

Merge r12276 r12292 r12297 from trunk, plus some mods for other platforms

Location:
branches/working-0711/ccl
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r12257 r12301  
    70507050
    70517051(defx862 x862-if if (seg vreg xfer testform true false &aux test-val)
    7052   (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testform)))
     7052  (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform)))
    70537053    (x862-form seg vreg xfer (if (nx-null test-val) false true))
    70547054    (let* ((cstack *x862-cstack*)
  • branches/working-0711/ccl/compiler/nx0.lisp

    r12242 r12301  
    359359
    360360(defun nx-proclaimed-parameter-p (sym)
     361  (setq sym (nx-need-sym sym))
    361362  (or (constantp sym)
    362363      (multiple-value-bind (special-p info) (nx-lex-info sym t)
     
    17311732     form)))
    17321733
    1733 (defun nx-constant-form-p (form)
     1734(defun nx2-constant-form-value (form)
    17341735  (setq form (nx-untyped-form form))
    17351736  (and (or (nx-null form)
     
    21652166            (not (%cdr form)))
    21662167       (nx-error "Illegally quoted form ~S." f))))
     2168
     2169(defun nx-form-constant-p (form env)
     2170  (declare (ignore env))
     2171  (or (quoted-form-p form)
     2172      (self-evaluating-p form)))
     2173
     2174(defun nx-form-constant-value (form env)
     2175  (declare (ignore env))
     2176  (declare (type (satisfies nx-form-constant-p) form))
     2177  (if (consp form) (%cadr form) form))
    21672178
    21682179; Returns two values: expansion & win
     
    24092420;;; Treat (VALUES x . y) as X if it appears in a THE form
    24102421(defun nx-form-type (form &optional (env *nx-lexical-environment*))
    2411   (if (quoted-form-p form)
    2412     (type-of (nx-unquote form))
    2413     (if (self-evaluating-p form)
    2414       (type-of form)
    2415       (if (and (consp form)             ; Kinda bogus now, but require-type
    2416                (eq (%car form) 'require-type) ; should be special some day
    2417                (quoted-form-p (caddr form)))
    2418         (%cadr (%caddr form))
    2419         (if (nx-trust-declarations env)
    2420           (if (symbolp form)
    2421             (nx-target-type (nx-declared-type form env))
    2422             (if (consp form)
    2423               (if (eq (%car form) 'the)
    2424                 (destructuring-bind (typespec val) (%cdr form)
    2425                   (declare (ignore val))
    2426                   (let* ((ctype (values-specifier-type typespec)))
    2427                     (if (typep ctype 'values-ctype)
    2428                       (let* ((req (values-ctype-required ctype)))
    2429                         (if req
    2430                           (nx-target-type (type-specifier (car req)))
    2431                           '*))
    2432                       (nx-target-type (type-specifier ctype)))))
    2433                 (if (eq (%car form) 'setq)
    2434                   (nx-declared-type (cadr form) env)
    2435                   (let* ((op (gethash (%car form) *nx1-operators*)))
    2436                     (or (and op (cdr (assq op *nx-operator-result-types*)))
    2437                         (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
    2438                         (and (memq (car form) *numeric-ops*)
    2439                              (grovel-numeric-form form env))
    2440                         (and (memq (car form) *logical-ops*)
    2441                              (grovel-logical-form form env))
    2442                         ;; Sort of the right idea, but this should be done
    2443                         ;; in a more general way.
    2444                         (when (or (eq (car form) 'aref)
    2445                                   (eq (car form) 'uvref))
    2446                           (let* ((atype (nx-form-type (cadr form) env))
    2447                                  (a-ctype (specifier-type atype)))
    2448                             (when (array-ctype-p a-ctype)
    2449                               (type-specifier (array-ctype-specialized-element-type
    2450                                                a-ctype)))))
    2451                         t))))
    2452               t))
    2453           t)))))
     2422  (if (nx-form-constant-p form env)
     2423    (type-of (nx-form-constant-value form env))
     2424    (if (and (consp form)          ; Kinda bogus now, but require-type
     2425             (eq (%car form) 'require-type) ; should be special some day
     2426             (nx-form-constant-p (caddr form) env))
     2427      (nx-form-constant-value (%caddr form) env)
     2428      (if (nx-trust-declarations env)
     2429        (if (symbolp form)
     2430          (nx-target-type (nx-declared-type form env))
     2431          (if (consp form)
     2432            (if (eq (%car form) 'the)
     2433              (destructuring-bind (typespec val) (%cdr form)
     2434                (declare (ignore val))
     2435                (let* ((ctype (values-specifier-type typespec)))
     2436                  (if (typep ctype 'values-ctype)
     2437                    (let* ((req (values-ctype-required ctype)))
     2438                      (if req
     2439                        (nx-target-type (type-specifier (car req)))
     2440                        '*))
     2441                    (nx-target-type (type-specifier ctype)))))
     2442              (if (eq (%car form) 'setq)
     2443                (nx-declared-type (cadr form) env)
     2444                (let* ((op (gethash (%car form) *nx1-operators*)))
     2445                  (or (and op (cdr (assq op *nx-operator-result-types*)))
     2446                      (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
     2447                      (and (memq (car form) *numeric-ops*)
     2448                           (grovel-numeric-form form env))
     2449                      (and (memq (car form) *logical-ops*)
     2450                           (grovel-logical-form form env))
     2451                      ;; Sort of the right idea, but this should be done
     2452                      ;; in a more general way.
     2453                      (when (or (eq (car form) 'aref)
     2454                                (eq (car form) 'uvref))
     2455                        (let* ((atype (nx-form-type (cadr form) env))
     2456                               (a-ctype (specifier-type atype)))
     2457                          (when (array-ctype-p a-ctype)
     2458                            (type-specifier (array-ctype-specialized-element-type
     2459                                             a-ctype)))))
     2460                      t))))
     2461            t))
     2462        t))))
    24542463
    24552464(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
     
    24922501(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
    24932502  (setq type (nx-target-type (type-expand type)))
    2494   (if (constantp arg)
    2495     (typep (nx-unquote arg) type env)
     2503  (if (nx-form-constant-p arg env)
     2504    (typep (nx-form-constant-value arg env) type env)
    24962505    (subtypep (nx-form-type arg env) type env)))
    24972506
  • branches/working-0711/ccl/compiler/nx1.lisp

    r12242 r12301  
    1919;;; Wimp out, but don't choke on (the (values ...) form)
    2020(defnx1 nx1-the the (&whole call typespec form &environment env)
    21   (if (and (self-evaluating-p form)
    22            (not (typep form typespec))
    23            (progn (nx1-whine :type call) t))
    24     (setq typespec t))
    2521  ;; Allow VALUES types here (or user-defined types that
    2622  ;; expand to VALUES types).  We could do a better job
     
    2925  ;; in type declarations, but aren't legal args to TYPEP;
    3026  ;; treat them as the simple FUNCTION type.
    31   (let* ((ctype (handler-case (values-specifier-type typespec env)
    32                   (parse-unknown-type (c)
    33                     (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    34                     nil)
    35                   (program-error (c)
    36                     (nx1-whine :invalid-type typespec c)
    37                     nil))))
    38     (if (or (null ctype) (typep ctype 'values-ctype))
    39       (setq typespec '*)
    40       (if (typep ctype 'function-ctype)
    41         (setq typespec 'function)       ; better than nothing.
    42         (setq typespec (nx-target-type (type-specifier ctype))))))
    43   (let* ((*nx-form-type* typespec)
    44          (transformed (nx-transform form env)))
    45     (when (and (consp transformed)
    46                (eq (car transformed) 'the))
    47       (setq transformed form))
    48     (make-acode
    49      (%nx1-operator typed-form)
    50      typespec
    51      (nx1-transformed-form transformed env)
    52      (nx-declarations-typecheck env))))
     27  (flet ((typespec-for-the (typespec)
     28           (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
     29                           (parse-unknown-type (c)
     30                                               (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
     31                                               nil)
     32                           (program-error (c)
     33                                          (nx1-whine :invalid-type typespec c)
     34                                          nil))))
     35             (if (or (null ctype) (typep ctype 'values-ctype))
     36               '*
     37               (if (typep ctype 'function-ctype)
     38                 'function
     39                 (nx-target-type (type-specifier ctype)))))))
     40    (let* ((typespec (typespec-for-the typespec))
     41           (*nx-form-type* typespec)
     42           (transformed (nx-transform form env)))
     43      (when (and (nx-form-constant-p transformed env)
     44                 (not (typep (nx-form-constant-value transformed env) typespec)))
     45        (nx1-whine :type call)
     46        (setq typespec t))
     47      (do* ()
     48           ((or (atom transformed)
     49                (not (eq (car transformed) 'the))))
     50        (destructuring-bind (ftype form) (cdr transformed)
     51          (setq typespec (nx-target-type (nx1-type-intersect call typespec (typespec-for-the ftype)))
     52                transformed form)))
     53      (make-acode
     54       (%nx1-operator typed-form)
     55       typespec
     56       (nx1-transformed-form transformed env)
     57       (nx-declarations-typecheck env)))))
    5358
    5459(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
     
    6974
    7075(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env)
    71   (if (and (quoted-form-p type) (symbolp (cadr type)))
     76  (if (and (nx-form-constant-p type env) (non-nil-symbol-p (nx-form-constant-value type env)))
    7277    (make-acode (%nx1-operator istruct-typep)
    7378                (nx1-immediate :eq)
     
    11161121  (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body)))
    11171122
    1118 (defnx1 nx1-%badarg ((%badarg)) (badthing right-type)
     1123(defnx1 nx1-%badarg ((%badarg)) (badthing right-type &environment env)
    11191124  (make-acode (%nx1-operator %badarg2)
    11201125              (nx1-form badthing)
    1121               (nx1-form (or (if (quoted-form-p right-type) (%typespec-id (cadr right-type))) right-type))))
     1126              (nx1-form (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env)))
     1127                            right-type))))
    11221128
    11231129(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
     
    14801486     (nx1-form value))))
    14811487
    1482 (defnx1 nx1-funcall ((funcall)) (func &rest args)
     1488(defnx1 nx1-funcall ((funcall)) (func &rest args &environment env)
    14831489  (let ((name func))
    14841490    (if (and (consp name)
     
    14971503      (nx1-form (cons name args))  ; This picks up call-next-method evil.
    14981504      (let* ((result-type t))
    1499         (when (and (quoted-form-p func)
    1500                    (or (typep (setq name (nx-unquote func)) 'symbol)
     1505        (when (and (nx-form-constant-p func env)
     1506                   (or (typep (setq name (nx-form-constant-value func env)) 'symbol)
    15011507                       (setq name (valid-function-name-p name))))
    15021508          (setq result-type (nx1-call-result-type name args nil t)))
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r12256 r12301  
    176176
    177177(defun eql-iff-eq-p (thing env)
    178   (if (quoted-form-p thing)
    179     (setq thing (%cadr thing))
    180     (if (not (self-evaluating-p thing))
    181         (return-from eql-iff-eq-p
    182           (or (nx-form-typep thing  'symbol env)
    183               (nx-form-typep thing 'character env)
    184               (nx-form-typep thing
    185                              '(or fixnum
    186                                #+64-bit-target single-float
    187                                symbol character
    188                                (and (not number) (not macptr))) env)))))
     178  (if (nx-form-constant-p thing env)
     179    (setq thing (nx-form-constant-value thing env))
     180    (return-from eql-iff-eq-p
     181      (or (nx-form-typep thing  'symbol env)
     182          (nx-form-typep thing 'character env)
     183          (nx-form-typep thing
     184                         '(or fixnum
     185                           #+64-bit-target single-float
     186                           symbol character
     187                           (and (not number) (not macptr))) env))))
    189188  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
    190189      (symbolp thing) (characterp thing)
     
    192191
    193192(defun equal-iff-eql-p (thing env)
    194   (if (quoted-form-p thing)
    195     (setq thing (%cadr thing))
    196     (if (not (self-evaluating-p thing))
    197       (return-from equal-iff-eql-p
    198         (nx-form-typep thing
    199                        '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
     193  (if (nx-form-constant-p thing env)
     194    (setq thing (nx-form-constant-value thing env))
     195    (return-from equal-iff-eql-p
     196      (nx-form-typep thing
     197                     '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))
    200198  (not (typep thing '(or cons string bit-vector pathname))))
    201199
     
    508506    (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
    509507        (let* ((limit (gensym))
    510                (upper (if (constantp n) n most-positive-fixnum))
     508               (upper (if (nx-form-constant-p n env) (nx-form-constant-value n env) most-positive-fixnum))
    511509               (top (gensym))
    512510               (test (gensym)))
     
    553551
    554552(define-compiler-macro if (&whole call test true &optional false &environment env)
    555   (multiple-value-bind (test test-win) (nx-transform test env)
    556     (if (or (quoted-form-p test) (self-evaluating-p test))
    557       (if (eval test)
     553  (let ((test-val (nx-transform test env)))
     554    (if (nx-form-constant-p test-val env)
     555      (if (nx-form-constant-value test-val env)
    558556        true
    559557        false)
    560       (if test-win
    561         `(if ,test ,@(cddr call))
    562         call))))
     558      call)))
    563559
    564560(define-compiler-macro %ilsr (&whole call &environment env shift value)
     
    648644(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
    649645  (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p))))
    650     (if (quoted-form-p dims)
    651       (let* ((dims (nx-unquote dims)))
     646    (if (nx-form-constant-p dims env)
     647      (let* ((dims (nx-form-constant-value dims env)))
    652648        (if (listp dims)
    653649          (progn
     
    677673                '*))))
    678674    (let* ((typespec (if element-type-p
    679                        (if (constantp element-type)
    680                          (nx-unquote element-type)
     675                       (if (nx-form-constant-p element-type env)
     676                         (nx-form-constant-value element-type env)
    681677                         '*)
    682678                       t))
     
    715711                       (comp-make-displaced-array dims keys)))
    716712                    ((or displaced-index-offset-p
    717                          (not (constantp element-type))
     713                         (not (nx-form-constant-p element-type env))
    718714                         (null (setq element-type-keyword
    719715                                     (target-element-type-type-keyword
    720                                       (eval element-type) env))))
     716                                      (nx-form-constant-value element-type env) env))))
    721717                     (comp-make-array-1 dims keys))
    722718                    ((and (typep element-type-keyword 'keyword)
     
    937933(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype)
    938934  (cond ((and (or (eq type t)
    939                   (and (quoted-form-p type)
    940                        (setq type (%cadr type))))
     935                  (and (nx-form-constant-p type env)
     936                       (setq type (nx-form-constant-value type env))))
    941937              (setq ctype (specifier-type-if-known type env :whine t)))
    942938         (cond ((nx-form-typep arg type env) arg)
     
    10551051              (loop-function (nx-form-sequence-iterator sequence env)))
    10561052          (if loop-function
    1057             (let ((item-var (unless (or (constantp item)
     1053            (let ((item-var (unless (or (nx-form-constant-p item env)
    10581054                                        (and (equal find-test '#'funcall)
    10591055                                             (function-form-p item)))
     
    11041100               (not (and test test-not)))
    11051101        (let ((position-test (or test test-not '#'eql))
    1106               (loop-test (if test-not 'unless 'when))
    1107               (sequence-value (if (constantp sequence)
    1108                                 (eval-constant sequence)
    1109                                 sequence)))
    1110           (cond ((nx-form-typep sequence-value 'list env)
    1111                  (let ((item-var (unless (or (constantp item)
     1102              (loop-test (if test-not 'unless 'when)))
     1103          (cond ((nx-form-typep sequence 'list env)
     1104                 (let ((item-var (unless (or (nx-form-constant-p item env)
    11121105                                             (and (equal position-test '#'funcall)
    11131106                                                  (function-form-p item)))
     
    11221115                                    (return ,position-var))
    11231116                        (incf ,position-var)))))
    1124                 ((nx-form-typep sequence-value 'vector env)
    1125                  (let ((item-var (unless (or (constantp item)
     1117                ((nx-form-typep sequence 'vector env)
     1118                 (let ((item-var (unless (or (nx-form-constant-p item env)
    11261119                                             (and (equal position-test '#'funcall)
    11271120                                                  (function-form-p item)))
     
    15761569
    15771570(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
    1578   (if (or (quoted-form-p type) (self-evaluating-p type))
    1579     (let ((type-val (nx-unquote type)))
     1571  (if (nx-form-constant-p type env)
     1572    (let ((type-val (nx-form-constant-value type env)))
    15801573      (if (eq type-val t)
    15811574        `(progn ,thing t)
    1582         (if (and (or (quoted-form-p thing) (self-evaluating-p thing))
     1575        (if (and (nx-form-constant-p thing env)
    15831576                 (specifier-type-if-known type-val env))
    1584           (typep (nx-unquote thing) type-val env)
     1577          (typep (nx-form-constant-value thing env) type-val env)
    15851578          (or (and (null e) (optimize-typep thing type-val env))
    15861579              call))))
     
    18851878  call)
    18861879
    1887 (define-compiler-macro make-string (&whole call size &rest keys)
     1880(define-compiler-macro make-string (&whole call &environment env size &rest keys)
    18881881  (if (constant-keywords-p keys)
    18891882    (destructuring-bind (&key (element-type () element-type-p)
     
    18911884                        keys
    18921885      (if (and element-type-p
    1893                (quoted-form-p element-type))
    1894         (let* ((element-type (cadr element-type)))
     1886               (nx-form-constant-p element-type env))
     1887        (let* ((element-type (nx-form-constant-value element-type env)))
    18951888          (if (subtypep element-type 'base-char)
    18961889            `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
     
    22662259
    22672260(define-compiler-macro coerce (&whole call &environment env thing type)
    2268   (cond ((quoted-form-p type)
    2269          (setq type (cadr type))
     2261  (cond ((nx-form-constant-p type env)
     2262         (setq type (nx-form-constant-value type env))
    22702263         (let ((ctype (specifier-type-if-known type env :whine t)))
    22712264           (if ctype
     
    23032296    call))
    23042297
    2305 (define-compiler-macro instance-slots (&whole w instance)
    2306   (if (and (constantp instance)
    2307            (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
     2298(define-compiler-macro instance-slots (&whole w instance &environment env)
     2299  (if (and (nx-form-constant-p instance env)
     2300           (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance)))
    23082301    `(instance.slots ,instance)
    23092302    (let* ((itemp (gensym))
     
    23882381;;; a package name is used as a constant argument to some functions.
    23892382
    2390 (defun package-ref-form (arg)
    2391   (when (and arg (constantp arg) (typep (setq arg (nx-unquote arg))
    2392                                         '(or symbol string)))
     2383(defun package-ref-form (arg env)
     2384  (when (and arg (nx-form-constant-p arg env)
     2385             (typep (setq arg (nx-form-constant-value arg env))
     2386                    '(or symbol string)))
    23932387    `(load-time-value (register-package-ref ,(string arg)))))
    23942388
    23952389
    23962390
    2397 (define-compiler-macro intern (&whole w string &optional package)
    2398   (let* ((ref (package-ref-form package)))
     2391(define-compiler-macro intern (&whole w string &optional package &environment env)
     2392  (let* ((ref (package-ref-form package env)))
    23992393    (if (or ref
    24002394            (setq ref (and (consp package)
     
    24022396                           (consp (cdr package))
    24032397                           (null (cddr package))
    2404                            (package-ref-form (cadr package)))))
     2398                           (package-ref-form (cadr package) env))))
    24052399      `(%pkg-ref-intern ,string ,ref)
    24062400      w)))
    24072401
    2408 (define-compiler-macro find-symbol (&whole w string &optional package)
    2409   (let* ((ref (package-ref-form package)))
     2402(define-compiler-macro find-symbol (&whole w string &optional package &environment env)
     2403  (let* ((ref (package-ref-form package env)))
    24102404    (if (or ref
    24112405            (setq ref (and (consp package)
     
    24132407                           (consp (cdr package))
    24142408                           (null (cddr package))
    2415                            (package-ref-form (cadr package)))))
     2409                           (package-ref-form (cadr package) env))))
    24162410      `(%pkg-ref-find-symbol ,string ,ref)
    24172411      w)))
    24182412
    2419 (define-compiler-macro find-package (&whole w package)
    2420   (let* ((ref (package-ref-form package)))
     2413(define-compiler-macro find-package (&whole w package &environment env)
     2414  (let* ((ref (package-ref-form package env)))
    24212415    (if ref
    24222416      `(package-ref.pkg ,ref)
    24232417      w)))
    24242418
    2425 (define-compiler-macro pkg-arg (&whole w package &optional allow-deleted)
    2426   (let* ((ref (unless allow-deleted (package-ref-form package))))
     2419(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted &environment env)
     2420  (let* ((ref (unless allow-deleted (package-ref-form package env))))
    24272421    (if ref
    24282422      (let* ((r (gensym)))
     
    24772471
    24782472
    2479 (define-compiler-macro register-istruct-cell (&whole w arg)
    2480   (if (and (quoted-form-p arg)
    2481            (cadr arg)
    2482            (typep (cadr arg) 'symbol))
    2483     `',(register-istruct-cell (cadr arg))
     2473(define-compiler-macro register-istruct-cell (&whole w arg &environment env)
     2474  (if (and (nx-form-constant-p arg env)
     2475           (setq arg (nx-form-constant-value arg env))
     2476           (symbolp arg))
     2477    `',(register-istruct-cell arg)
    24842478    w))
    24852479
  • branches/working-0711/ccl/level-1/l1-sockets.lisp

    r12203 r12301  
    14321432#+windows-target
    14331433(defun %get-ip-interfaces ()
    1434   (let* ((handle (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
     1434  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
    14351435    (unwind-protect
    14361436    (rlet ((realoutlen #>DWORD 0))
     
    14401440        (%stack-block ((buf reservedlen))
    14411441          (unless (eql 0 (#_WSAIoctl
    1442                           handle
     1442                          socket
    14431443                          #$SIO_GET_INTERFACE_LIST
    14441444                          (%null-ptr)
     
    14691469                          interfaces)))
    14701470                (return interfaces)))))))
    1471       (#_CloseHandle (%int-to-ptr handle)))))
     1471      (#_closesocket socket))))
    14721472
    14731473     
  • branches/working-0711/ccl/lib/ffi-darwinppc64.lisp

    r7376 r12301  
    117117                         (w 0 (+ w 4)))
    118118                        ((>= b bits))
    119                      (declare (fixnum b 0))
     119                     (declare (fixnum b w))
    120120                     (forms `(setf (%get-unsigned-long ,r ,w)
    121121                              (%get-unsigned-long ,regbuf ,w)))))
     
    171171                         (w 0 (+ w 4)))
    172172                        ((>= b bits))
    173                      (declare (fixnum b 0))
     173                     (declare (fixnum b w))
    174174                     (forms `(setf (%get-unsigned-long ,stack-ptr ,w)
    175175                              (%get-unsigned-long ,r ,w)))))
  • branches/working-0711/ccl/lib/format.lisp

    r11808 r12301  
    14551455    (cond ((and atsign (not colon))
    14561456           (prin1 char stream))
    1457           ((< 127 code)
    1458            (write-char char stream)
    1459            (when (and atsign
    1460                       (neq #\Null (setq char (code-char (logand 127 code)))))
    1461              (princ " (Meta " stream)
    1462              (write-char char stream)
    1463              (write-char #\) stream)))
     1457          (colon
     1458           (if (or (eql char #\space)
     1459                   (not (graphic-char-p char)))
     1460             (princ name stream)
     1461             (write-char char stream)))
    14641462          ((not (or atsign colon))
    14651463           (write-char char stream))
  • branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c

    r12198 r12301  
    12841284#endif
    12851285        argv[argc] = NULL;
     1286        if (shadow) {
     1287          shadow[argc] = NULL;
     1288        }
    12861289      }
    12871290    }
     
    16241627
    16251628  for (i = 0; i < argc; i++) {
    1626     argv[i] = utf_16_to_utf_8(wide_argv[i]);
     1629    if (wide_argv[i]) {
     1630      argv[i] = utf_16_to_utf_8(wide_argv[i]);
     1631    } else {
     1632      argv[i] = NULL;
     1633    }
    16271634  }
    16281635  return argv;
  • branches/working-0711/ccl/lisp-kernel/ppc-spentry.s

    r12198 r12301  
    33563356push_pair_test:
    33573357        __(bne cr0,push_pair_loop)
    3358         __(slwi imm2,imm2,3)            /* pairs -> bytes  */
     3358        __(slwi imm2,imm2,dnode_shift)  /* pairs -> bytes  */
    33593359        __(add imm2,vsp,imm2)           /* imm2 points below pairs  */
    33603360        __(li imm0,0)                   /* count unknown keywords so far  */
     
    33933393        __(addi imm0,imm0,1)
    33943394        __(cmpr(cr4,imm0,nargs))
    3395         __(addi imm3,imm3,4)
     3395        __(addi imm3,imm3,node_size)
    33963396        __(bne cr0,match_test)
    33973397        /* Got a hit.  Unless this keyword's been seen already, set it.  */
    3398         __(slwi imm0,imm0,3)
     3398        __(slwi imm0,imm0,dnode_shift)
    33993399        __(subf imm0,imm0,imm2)
    34003400        __(ldr(temp0,0(imm0)))
     
    34093409        __(bne cr4,match_loop)
    34103410        __(beq cr3,match_keys_check_aok)
    3411         __(addi imm1,imm1,4)
     3411        __(addi imm1,imm1,node_size)
    34123412        __(b match_keys_loop)
    34133413match_keys_check_aok:
     
    39333933local_label(misc_set_u64):
    39343934         __(extract_lisptag(imm0,arg_z))
     3935         __(extract_fulltag(imm2,arg_z))
    39353936         __(cmpdi cr0,arg_z,0)
    39363937         __(cmpdi cr7,imm0,0)
     3938         __(cmpdi cr6,imm2,fulltag_misc)
    39373939         __(la imm4,misc_data_offset(arg_y))
    39383940         __(bne cr7,local_label(setu64_maybe_bignum))
  • branches/working-0711/ccl/lisp-kernel/windows-calls.c

    r12198 r12301  
    273273lisp_close(HANDLE hfile)
    274274{
     275  int err;
     276
     277  if (closesocket((SOCKET)hfile) == 0) {
     278    return 0;
     279  }
     280
     281  err = WSAGetLastError();
     282  if (err != WSAENOTSOCK) {
     283    _dosmaperr(err);
     284    return -1;
     285  }
    275286  if (CloseHandle(hfile)) {
    276287    return 0;
Note: See TracChangeset for help on using the changeset viewer.