Changeset 6563 for branches

Timestamp:

May 17, 2007, 12:05:28 AM (18 years ago)

Author:

Gary Byers

Message:

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

File:

• branches/tfe/ccl/compiler/tfe/tenv.lisp (modified) (1 diff)

branches/tfe/ccl/compiler/tfe/tenv.lisp

@@ -153 +153 @@
         (dolist (v vars) (tenv-check-var-usage v))))))
 
+;;; Pending declarations
+(defstruct tenv-pending-declarations
+  vdecls
+  fdecls
+  mdecls)
+
+(defvar *tenv-standard-declaration-handlers* ())
+
+(defun tenv-bad-decls (decl)
+  (tgen-warn "Invalid declaration: ~s" decl))
+
+(defmacro deftenvdecl (sym lambda-list &body forms)
+  (multiple-value-bind (body decls) (parse-body forms nil t)
+    `(setf (getf *tenv-standard-declaration-handlers* ',sym )
+           (function (lambda ,lambda-list
+                       ,@decls
+                       ,@body)))))
+
+(deftenvdecl special (pending decl env)
+  (declare (ignore env))
+  (dolist (s (%cdr decl))
+    (if (symbolp s) 
+      (tenv-new-vdecl pending s 'special)
+      (tenv-bad-decls decl))))
+
+(deftenvdecl dynamic-extent (pending decl env)
+  (declare (ignore env))
+  (dolist (s (%cdr decl))
+    (if (symbolp s) 
+      (tenv-new-vdecl pending s 'dynamic-extent t)
+      (if (and (consp s)
+               (eq (%car s) 'function)
+               (consp (%cdr s))
+               (valid-function-name-p (cadr s))
+               (setq s (validate-function-name (cadr s))))
+        (tenv-new-fdecl pending s 'dynamic-extent t)
+        (tenv-bad-decls decl)))))
+
+(deftenvdecl ignorable (pending decl env)
+  (declare (ignore env))
+  (dolist (s (%cdr decl))
+    (if (symbolp s) 
+      (tenv-new-vdecl pending s 'ignore-if-unused t)
+      (if (and (consp s)
+               (eq (%car s) 'function)
+               (consp (%cdr s))
+               (valid-function-name-p (cadr s))
+               (setq s (validate-function-name (cadr s))))
+        (tenv-new-fdecl pending s 'ignore-if-unused t)
+        (tenv-bad-decls decl)))))
+
+(deftenvdecl ftype (pending decl env)
+  (declare (ignore env))
+  (destructuring-bind (type &rest fnames) (%cdr decl)
+    (dolist (s fnames)
+      (tenv-new-fdecl pending s 'ftype type))))
+
+(deftenvdecl settable (pending decl env)
+  (tenv-settable-decls pending decl env t))
+
+(deftenvdecl unsettable (pending decl env)
+  (tenv-settable-decls pending decl env nil))
+
+(defun tenv-settable-decls (pending decl env val)
+  (declare (ignore env))
+  (dolist (s (%cdr decl))
+    (if (symbolp s)
+      (tenv-new-vdecl pending s 'settable val)
+      (tenv-bad-decls decl))))
+
+(deftenvdecl type (pending decl env)
+  (declare (ignore env))
+  (let* ((spec (%cdr decl))
+         (type (car spec))
+         (ctype (specifier-type type)))
+    (unless (typep ctype 'unknown-ctype)
+      (dolist (sym (cdr spec))
+        (if (symbolp sym)
+          (tenv-new-vdecl pending sym 'type (type-specifier ctype))
+          (tenv-bad-decls decl))))))
+
+(defun tenv-inline-decl (pending decl val &aux valid-name)
+  (dolist (s (%cdr decl))
+    (multiple-value-setq (valid-name s) (valid-function-name-p s))
+    (if valid-name
+      (progn
+        (if (tenv-self-call-p s nil t)
+          (setq *tenv-inlined-self* val))
+        (tenv-new-fdecl pending s 'inline (if val 'inline 'notinline)))
+      (tenv-bad-decls decl))))
+
+(deftenvdecl inline (pending decl env)
+  (declare (ignore env))
+  (tenv-inline-decl pending decl t))
+
+(deftenvdecl notinline (pending decl env)
+  (declare (ignore env))
+  (tenv-inline-decl pending decl nil))
+
+
+(defun tenv-new-vdecl (pending name class &optional info)
+  (push (cons name (cons class info)) (tenv-pending-declarations-vdecls pending)))
+
+(defun tenv-new-fdecl (pending name class &optional info)
+  (push (cons name (cons class info)) (tenv-pending-declarations-fdecls pending)))
+
+(defun tenv-new-mdecl (pending name class &optional info)
+  (push (cons name (cons class info)) (tenv-pending-declarations-mdecls pending)))
+
+
+
 (provide "TENV")