← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpmac.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpmac.lsp
 
1
;;; ----------------------------------------------------------------------
 
2
;;; Macros only used in the code of the compiler itself:
 
3
 
 
4
(in-package "COMPILER")
 
5
(import 'sys::arglist "COMPILER")
 
6
 
 
7
(defun same-fname-p (name1 name2) (equal name1 name2))
 
8
 
 
9
;;; from cmpenv.lsp
 
10
(defmacro next-cmacro () '(incf *next-cmacro*))
 
11
 
 
12
;;; from cmplabel.lsp
 
13
(defmacro next-label () `(cons (incf *last-label*) nil))
 
14
 
 
15
(defmacro next-label* () `(cons (incf *last-label*) t))
 
16
 
 
17
(defmacro wt-go (label)
 
18
  `(progn (rplacd ,label t) (wt "goto L" (car ,label) ";")))
 
19
 
 
20
;;; from cmplam.lsp
 
21
(defmacro ck-spec (condition)
 
22
  `(unless ,condition
 
23
           (cmperr "The parameter specification ~s is illegal." spec)))
 
24
 
 
25
(defmacro ck-vl (condition)
 
26
  `(unless ,condition
 
27
           (cmperr "The lambda list ~s is illegal." vl)))
 
28
 
 
29
;;; fromcmputil.sp
 
30
(defmacro cmpck (condition string &rest args)
 
31
  `(if ,condition (cmperr ,string ,@args)))
 
32
 
 
33
(defmacro cmpassert (condition string &rest args)
 
34
  `(unless ,condition (error ,string ,@args)))
 
35
 
 
36
;;; from cmpwt.lsp
 
37
(defmacro wt (&rest forms &aux (fl nil))
 
38
  (dolist (form forms (cons 'progn (nreverse (cons nil fl))))
 
39
    (if (stringp form)
 
40
        (push `(princ ,form *compiler-output1*) fl)
 
41
        (push `(wt1 ,form) fl))))
 
42
 
 
43
(defmacro wt-h (&rest forms &aux (fl nil))
 
44
  (dolist (form forms)
 
45
    (if (stringp form)
 
46
      (push `(princ ,form *compiler-output2*) fl)
 
47
      (push `(wt-h1 ,form) fl)))
 
48
  `(progn (terpri *compiler-output2*) ,@(nreverse (cons nil fl))))
 
49
 
 
50
(defmacro princ-h (form) `(princ ,form *compiler-output2*))
 
51
 
 
52
(defmacro wt-nl (&rest forms)
 
53
  `(wt #\Newline #\Tab ,@forms))
 
54
 
 
55
(defmacro wt-nl1 (&rest forms)
 
56
  `(wt #\Newline ,@forms))
 
57
 
 
58
(defmacro safe-compile ()
 
59
  `(>= *safety* 2))
 
60
 
 
61
(defmacro compiler-check-args ()
 
62
  `(>= *safety* 1))
 
63
 
 
64
(defmacro compiler-push-events ()
 
65
  `(>= *safety* 3))
 
66
 
 
67
;; ----------------------------------------------------------------------
 
68
;; C1-FORMS
 
69
;;
 
70
 
 
71
(defstruct (c1form (:include info)
 
72
                   (:print-object print-c1form)
 
73
                   (:constructor do-make-c1form))
 
74
  (name nil)
 
75
  (parent nil)
 
76
  (args '()))
 
77
 
 
78
(defun print-c1form (form stream)
 
79
  (format stream "#<form ~A ~X>" (c1form-name form) (ext::pointer form)))
 
80
 
 
81
(defun make-c1form (name subform &rest args)
 
82
  (let ((form (do-make-c1form :name name :args args
 
83
                              :type (info-type subform)
 
84
                              :sp-change (info-sp-change subform)
 
85
                              :volatile (info-volatile subform))))
 
86
    (c1form-add-info form args)
 
87
    form))
 
88
 
 
89
(defun make-c1form* (name &rest args)
 
90
  (let ((info-args '())
 
91
        (form-args '()))
 
92
    (do ((l args (cdr l)))
 
93
        ((endp l))
 
94
      (let ((key (first l)))
 
95
        (cond ((not (keywordp key))
 
96
               (baboon))
 
97
              ((eq key ':args)
 
98
               (setf form-args (rest l))
 
99
               (return))
 
100
              (t
 
101
               (setf info-args (list* key (second l) info-args)
 
102
                     l (cdr l))))))
 
103
    (let ((form (apply #'do-make-c1form :name name :args form-args
 
104
                       info-args)))
 
105
      (c1form-add-info form form-args)
 
106
      form)))
 
107
 
 
108
(defun c1form-add-info (form dependents)
 
109
  (dolist (subform dependents form)
 
110
    (cond ((c1form-p subform)
 
111
           (when (info-sp-change subform)
 
112
             (setf (info-sp-change form) t))
 
113
           (setf (c1form-parent subform) form))
 
114
          ((consp subform)
 
115
           (c1form-add-info form subform)))))
 
116
 
 
117
(defun copy-c1form (form)
 
118
  (copy-structure form))
 
119
 
 
120
(defmacro c1form-arg (nth form)
 
121
  (case nth
 
122
    (0 `(first (c1form-args ,form)))
 
123
    (1 `(second (c1form-args ,form)))
 
124
    (otherwise `(nth ,nth (c1form-args ,form)))))
 
125
 
 
126
(defun c1form-volatile* (form)
 
127
  (if (c1form-volatile form) "volatile " ""))
 
128
 
 
129
(defun c1form-primary-type (form)
 
130
  (let ((type (c1form-type form)))
 
131
    (when (and (consp type) (eq (first type) 'VALUES))
 
132
      (let ((subtype (second type)))
 
133
        (when (or (eq subtype '&optional)       (eq subtype '&rest))
 
134
          (setf subtype (third (c1form-type form)))
 
135
          (when (eq subtype '&optional)
 
136
            (cmperr "Syntax error in type expression ~S" type)))
 
137
        (when (eq subtype '&rest)
 
138
          (cmperr "Syntax error in type expression ~S" type))
 
139
        (setf type subtype)))
 
140
    type))
 
141
 
 
142
(defun find-node-in-list (home-node list)
 
143
  (flet ((parent-node-p (node presumed-child)
 
144
           (loop
 
145
            (cond ((null presumed-child) (return nil))
 
146
                  ((eq node presumed-child) (return t))
 
147
                  (t (setf presumed-child (c1form-parent presumed-child)))))))
 
148
    (member home-node list :test #'parent-node-p)))