Changeset 6563


Ignore:
Timestamp:
May 17, 2007, 7:05:28 AM (13 years ago)
Author:
gb
Message:

Some more env-processing stuff, just copied from nx.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/tfe/ccl/compiler/tfe/tenv.lisp

    r6551 r6563  
    153153        (dolist (v vars) (tenv-check-var-usage v))))))
    154154
     155;;; Pending declarations
     156(defstruct tenv-pending-declarations
     157  vdecls
     158  fdecls
     159  mdecls)
     160
     161(defvar *tenv-standard-declaration-handlers* ())
     162
     163(defun tenv-bad-decls (decl)
     164  (tgen-warn "Invalid declaration: ~s" decl))
     165
     166(defmacro deftenvdecl (sym lambda-list &body forms)
     167  (multiple-value-bind (body decls) (parse-body forms nil t)
     168    `(setf (getf *tenv-standard-declaration-handlers* ',sym )
     169           (function (lambda ,lambda-list
     170                       ,@decls
     171                       ,@body)))))
     172
     173(deftenvdecl special (pending decl env)
     174  (declare (ignore env))
     175  (dolist (s (%cdr decl))
     176    (if (symbolp s)
     177      (tenv-new-vdecl pending s 'special)
     178      (tenv-bad-decls decl))))
     179
     180(deftenvdecl dynamic-extent (pending decl env)
     181  (declare (ignore env))
     182  (dolist (s (%cdr decl))
     183    (if (symbolp s)
     184      (tenv-new-vdecl pending s 'dynamic-extent t)
     185      (if (and (consp s)
     186               (eq (%car s) 'function)
     187               (consp (%cdr s))
     188               (valid-function-name-p (cadr s))
     189               (setq s (validate-function-name (cadr s))))
     190        (tenv-new-fdecl pending s 'dynamic-extent t)
     191        (tenv-bad-decls decl)))))
     192
     193(deftenvdecl ignorable (pending decl env)
     194  (declare (ignore env))
     195  (dolist (s (%cdr decl))
     196    (if (symbolp s)
     197      (tenv-new-vdecl pending s 'ignore-if-unused t)
     198      (if (and (consp s)
     199               (eq (%car s) 'function)
     200               (consp (%cdr s))
     201               (valid-function-name-p (cadr s))
     202               (setq s (validate-function-name (cadr s))))
     203        (tenv-new-fdecl pending s 'ignore-if-unused t)
     204        (tenv-bad-decls decl)))))
     205
     206(deftenvdecl ftype (pending decl env)
     207  (declare (ignore env))
     208  (destructuring-bind (type &rest fnames) (%cdr decl)
     209    (dolist (s fnames)
     210      (tenv-new-fdecl pending s 'ftype type))))
     211
     212(deftenvdecl settable (pending decl env)
     213  (tenv-settable-decls pending decl env t))
     214
     215(deftenvdecl unsettable (pending decl env)
     216  (tenv-settable-decls pending decl env nil))
     217
     218(defun tenv-settable-decls (pending decl env val)
     219  (declare (ignore env))
     220  (dolist (s (%cdr decl))
     221    (if (symbolp s)
     222      (tenv-new-vdecl pending s 'settable val)
     223      (tenv-bad-decls decl))))
     224
     225(deftenvdecl type (pending decl env)
     226  (declare (ignore env))
     227  (let* ((spec (%cdr decl))
     228         (type (car spec))
     229         (ctype (specifier-type type)))
     230    (unless (typep ctype 'unknown-ctype)
     231      (dolist (sym (cdr spec))
     232        (if (symbolp sym)
     233          (tenv-new-vdecl pending sym 'type (type-specifier ctype))
     234          (tenv-bad-decls decl))))))
     235
     236(defun tenv-inline-decl (pending decl val &aux valid-name)
     237  (dolist (s (%cdr decl))
     238    (multiple-value-setq (valid-name s) (valid-function-name-p s))
     239    (if valid-name
     240      (progn
     241        (if (tenv-self-call-p s nil t)
     242          (setq *tenv-inlined-self* val))
     243        (tenv-new-fdecl pending s 'inline (if val 'inline 'notinline)))
     244      (tenv-bad-decls decl))))
     245
     246(deftenvdecl inline (pending decl env)
     247  (declare (ignore env))
     248  (tenv-inline-decl pending decl t))
     249
     250(deftenvdecl notinline (pending decl env)
     251  (declare (ignore env))
     252  (tenv-inline-decl pending decl nil))
     253
     254
     255(defun tenv-new-vdecl (pending name class &optional info)
     256  (push (cons name (cons class info)) (tenv-pending-declarations-vdecls pending)))
     257
     258(defun tenv-new-fdecl (pending name class &optional info)
     259  (push (cons name (cons class info)) (tenv-pending-declarations-fdecls pending)))
     260
     261(defun tenv-new-mdecl (pending name class &optional info)
     262  (push (cons name (cons class info)) (tenv-pending-declarations-mdecls pending)))
     263
     264
     265
    155266(provide "TENV")
    156267
Note: See TracChangeset for help on using the changeset viewer.