Ignore:
Timestamp:
Aug 1, 2009, 3:50:08 PM (10 years ago)
Author:
gz
Message:

ftypes - r12467/r12500/r12512/r12514 from trunk

File:
1 edited

Legend:

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

    r12340 r12515  
    2828           (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
    2929                           (parse-unknown-type (c)
    30                                                (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    31                                                nil)
     30                             (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
     31                             nil)
    3232                           (program-error (c)
    33                                           (nx1-whine :invalid-type typespec c)
    34                                           nil))))
    35              (if (or (null ctype) (typep ctype 'values-ctype))
     33                              (nx1-whine :invalid-type typespec c)
     34                              nil))))
     35             (if (null ctype)
    3636               '*
    3737               (if (typep ctype 'function-ctype)
    3838                 'function
    39                  (nx-target-type (type-specifier ctype)))))))
     39                 (nx-target-type (type-specifier (single-value-type ctype))))))))
    4040    (let* ((typespec (typespec-for-the typespec))
    4141           (*nx-form-type* typespec)
    4242           (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))
    4743      (flet ((fold-the ()
    4844               (do* ()
     
    6359          (when (eq transformed last)
    6460            (return)))
     61        (when (and (nx-form-constant-p transformed env)
     62                   (not (typep (nx-form-constant-value transformed env) typespec)))
     63          (nx1-whine :type call)
     64          (setq typespec t))
     65        (setq typespec (nx-target-type
     66                        (or (nx1-type-intersect call
     67                                                typespec
     68                                                (typespec-for-the (nx-form-type transformed env)))
     69                            t)))
    6570        (make-acode
    6671         (%nx1-operator typed-form)
     
    11601165
    11611166
    1162 
    1163 
    1164                          
    1165 
    1166 (defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &aux (orig args) (spread-p t))
    1167   (if (null (%car (last (push arg args))))
    1168     (setq spread-p nil args (butlast args)))
    1169   (let ((name (nx1-func-name fn))
    1170         (global nil)
    1171         (result-type t))
    1172     (when name
    1173       (setq global (eq (%car fn) 'quote)
    1174             result-type (nx1-call-result-type name args spread-p global))
    1175       (if global (setq name (nx1-form fn))))
    1176     (if name
    1177       (unless global
    1178         (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
    1179           (when (and afunc (eq afunc *nx-call-next-method-function*))
    1180             (setq name (if (or arg orig)
    1181                          '%call-next-method-with-args
    1182                          '%call-next-method)
    1183                          global t
    1184                          args (cons (var-name *nx-next-method-var*) args)))))
    1185       (setq name (nx1-form fn)))
    1186     (let* ((form (nx1-call name args spread-p global)))
    1187       (if (eq result-type t)
    1188         form
    1189         (make-acode (%nx1-operator typed-form) result-type form)))))
    1190 
    1191 (defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args))
    1192   (push arg args)
    1193   (let ((name (nx1-func-name fn))
    1194         (global nil))
    1195     (if name
    1196       (if (eq (%car fn) 'quote)
    1197         (setq global t name (nx1-form fn))
    1198         (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
    1199           (when (and afunc (eq afunc *nx-call-next-method-function*))
    1200             (setq name (if (or arg orig)
    1201                          '%call-next-method-with-args
    1202                          '%call-next-method)
    1203                   global t
    1204                   args (cons (var-name *nx-next-method-var*) args)))))
    1205       (setq name (nx1-form fn)))
    1206     (nx1-call name args 0 global)))
    1207 
     1167(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env)
     1168  (let ((last (%car (last (push arg args)))))
     1169    (if (and (nx-form-constant-p last env)
     1170             (null (nx-form-constant-value last env)))
     1171      (nx1-form (let ((new `(funcall ,fn ,@(butlast args))))
     1172                  (nx-note-source-transformation call new)
     1173                  new))
     1174      (nx1-apply-fn fn args t))))
     1175
     1176(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args)
     1177  (nx1-apply-fn fn (cons arg args) 0))
     1178
     1179(defun nx1-apply-fn (fn args spread)
     1180  (let* ((sym (nx1-func-name fn))
     1181         (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym)))))
     1182    (when (and afunc (eq afunc *nx-call-next-method-function*))
     1183      (setq fn (let ((new (list 'quote (if (or (car args) (cdr args))
     1184                                         '%call-next-method-with-args
     1185                                         '%call-next-method))))
     1186                 (nx-note-source-transformation fn new)
     1187                 new)
     1188            sym nil
     1189            args (cons (var-name *nx-next-method-var*) args)))
     1190    (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread)))
    12081191
    12091192
     
    12811264             (setq symbol (cadr sym))
    12821265             (symbolp symbol))
    1283       (progn
    1284         (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
     1266      (let ((env *nx-lexical-environment*))
     1267        (unless (or (nx1-find-call-def symbol env)
     1268                    (find-ftype-decl symbol env)
     1269                    (eq symbol *nx-global-function-name*))
     1270          (nx1-whine :undefined-function symbol))
    12851271        (make-acode (%nx1-default-operator) symbol))
    12861272      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
     
    14991485     (nx1-form value))))
    15001486
    1501 (defnx1 nx1-funcall ((funcall)) (func &rest args &environment env)
    1502   (let ((name func))
    1503     (if (and (consp name)
    1504              (eq (%car name) 'function)
    1505              (consp (%cdr name))
    1506              (null (%cddr name))
    1507              (or
    1508               (if (symbolp (setq name (%cadr name)))
    1509                 (or (not (macro-function name *nx-lexical-environment*))
    1510                     (nx-error "Can't funcall macro function ~s ." name)))
    1511               (and (consp name)
    1512                    (or (when (eq (%car name) 'lambda)
    1513                          (nx-note-source-transformation func name)
    1514                          t)
    1515                        (setq name (nx-need-function-name name))))))
    1516       (nx1-form (cons name args))  ; This picks up call-next-method evil.
    1517       (let* ((result-type t))
    1518         (when (and (nx-form-constant-p func env)
    1519                    (or (typep (setq name (nx-form-constant-value func env)) 'symbol)
    1520                        (setq name (valid-function-name-p name))))
    1521           (setq result-type (nx1-call-result-type name args nil t)))
    1522         (let* ((form (nx1-call (nx1-form func) args nil t)))
    1523           (if (eq result-type t)
    1524             form
    1525             (make-acode (%nx1-operator typed-form) result-type form)))))))
     1487(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env)
     1488  (let ((name (nx1-func-name func)))
     1489    (if (or (null name)
     1490            (and (symbolp name) (macro-function name env)))
     1491      (nx1-typed-call (nx1-form func) args nil)
     1492      (progn
     1493        (when (consp name) ;; lambda expression
     1494          (nx-note-source-transformation func name))
     1495        ;; This picks up call-next-method evil.
     1496        (nx1-form (let ((new-form (cons name args)))
     1497                    (nx-note-source-transformation call new-form)
     1498                    new-form))))))
    15261499
    15271500(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
     
    15291502              (nx1-form value-form)
    15301503              (nx1-formlist args)))
    1531 
    1532 #|
    1533 (defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
    1534   (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
    1535     (make-acode (%nx1-operator immediate) name)
    1536     (or name (nx1-form fn))))
    1537 |#
    15381504
    15391505(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
     
    20392005
    20402006(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
    2041   (declare (ftype (function (t t t t)) %define-x86-lap-function))
     2007  (declare (ftype (function (t t t)) %define-x86-lap-function))
    20422008  (require "X86-LAP")
    20432009  (setf (afunc-lfun *nx-current-function*)
Note: See TracChangeset for help on using the changeset viewer.