add avm2 exception handler support to assembler
[swf2.git] / lib / sicl-iteration.lisp
blob6cbe70682ef0da11d9763fc3ad5703a86d6f1b47
1 (in-package #:avm2-compiler)
3 ;;; pieces of sicl/iteration.lisp that work so far
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;;;
7 ;;; Conditions
9 (define-condition expected-symbol (program-error)
10 ((%found :initarg :found :reader found))
11 (:report
12 (lambda (condition stream)
13 (princ "Expected a symbol but found: " stream)
14 (print (found condition) stream))))
16 (define-condition malformed-body (program-error)
17 ((%body :initarg :body :reader body))
18 (:report
19 (lambda (condition stream)
20 (princ "Expected a body in the form of" stream)
21 (terpri stream)
22 (princ "a proper list, but found: ")
23 (print (body condition) stream))))
25 (define-condition malformed-variable-clauses (program-error)
26 ((%found :initarg :found :reader found))
27 (:report
28 (lambda (condition stream)
29 (princ "Expected a proper list of variable clauses," stream)
30 (terpri stream)
31 (princ "but found: " stream)
32 (print (found condition) stream))))
34 (define-condition malformed-variable-clause (program-error)
35 ((%found :initarg :found :reader found))
36 (:report
37 (lambda (condition stream)
38 (princ "Expected a variable clause of the form" stream)
39 (terpri stream)
40 (princ "var, (var), (var init-form), or (var init-form step-form),"
41 stream)
42 (terpri stream)
43 (princ "but found: " stream)
44 (print (found condition) stream))))
46 (define-condition malformed-end-test (program-error)
47 ((%found :initarg :found :reader found))
48 (:report
49 (lambda (condition stream)
50 (princ "Expected an end test clause of the form" stream)
51 (terpri stream)
52 (princ "(end-test result-form*)," stream)
53 (terpri stream)
54 (princ "but found: " stream)
55 (print (found condition) stream))))
57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 ;;;
59 ;;; Utilities
61 ;;; Split a body into declarations and forms.
62 (defun split-body (body &optional declarations)
63 (if (or (null body)
64 (not (consp (car body)))
65 (not (eq (caar body) 'declare)))
66 (values (nreverse declarations) body)
67 (split-body (cdr body) (cons (car body) declarations))))
69 ;;; Check that an object is a proper list
70 (defun proper-list-p (object)
71 (or (null object)
72 (and (consp object)
73 (proper-list-p (cdr object)))))
75 ;;; For do and do* we need to map over the variable binding clauses.
76 ;;; We therefore need mapcar or something similar. But in order to
77 ;;; avoid introducing a dependency on sequence operations, we define
78 ;;; our own mapcar using only recursion.
80 (defun local-mapcar (function list)
81 (if (null list)
82 '()
83 (cons (funcall function (car list))
84 (local-mapcar function (cdr list)))))
86 (let ((*symbol-table* *cl-symbol-table*))
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;;;
90 ;;; Macros dolist and dotimes
92 ;;; The spec says that the variable is bound to nil when the
93 ;;; result-form is evaluated. But we don't want the declarations to
94 ;;; have to include nil as one of the values of var. For that reason,
95 ;;; there needs to be a different binding of the variable when the
96 ;;; forms of the body are evaluated and when the result-form is
97 ;;; evaluated.
99 ;;; The spec says we have a choice between binding or assigning the
100 ;;; variable in each iteration. For dolist, choosing assignment gets
101 ;;; complicated in the first iteration though, because we would have
102 ;;; to come up with an initial value of the variable that is
103 ;;; compatible with the declarations. For that reason, we choose to
104 ;;; bind it.
107 (swf-defmacro dolist ((var list-form &optional result-form) &body body)
108 (progn;; do some syntax checking
109 (unless (symbolp var)
110 (error 'expected-symbol :found var))
111 (unless (proper-list-p body)
112 (error 'malformed-body :body body))
113 (multiple-value-bind (declarations forms)
114 (split-body body)
115 (let ((start-tag (gensym "START"))
116 (end-tag (gensym "END"))
117 (list-var (gensym "LIST-VAR")))
118 `(let ((,list-var ,list-form)
119 (,var nil))
120 ,@declarations
121 (block nil
122 (tagbody
123 (when (endp ,list-var)
124 (go ,end-tag))
125 #+nil(%go-when (endp ,list-var) ,end-tag)
126 ,start-tag
127 (setq ,var (pop ,list-var))
128 (tagbody ,@forms)
129 (when ,list-var
130 (go ,start-tag))
131 #+nil(%go-when ,list-var ,start-tag)
132 ,end-tag)
133 (let ((,var nil))
134 #+nil(declare (ignorable ,var))
135 ,result-form)))))))
137 ;;; For dotimes, we don't have the problem of initial value which is
138 ;;; always 0, so we can bind the variable once for the entire loop
139 ;;; body.
141 (swf-defmacro dotimes ((var count-form &optional result-form) &body body)
142 ;; do some syntax checking
143 (unless (symbolp var)
144 (error 'expected-symbol :found var))
145 (unless (proper-list-p body)
146 (error 'malformed-body :body body))
147 (multiple-value-bind (declarations forms)
148 (split-body body)
149 (let ((start-tag (gensym))
150 (end-tag (gensym))
151 (count-var (gensym)))
152 `(let ((,count-var ,count-form)
153 (,var 0))
154 #+nil(declare (type integer ,var))
155 ,@declarations
156 (block nil
157 (tagbody
158 (when (= ,var ,count-var)
159 (go ,end-tag))
160 ,start-tag
161 (tagbody ,@forms)
162 (incf ,var)
163 (unless (= ,var ,count-var)
164 (go ,start-tag))
165 ,end-tag)
166 (let ((,var nil))
167 #+nil(declare (ignorable ,var))
168 ,result-form))))))
170 (defun check-variable-clauses (variable-clauses)
171 (unless (proper-list-p variable-clauses)
172 (error 'malformed-variable-clauses :found variable-clauses))
173 (local-mapcar
174 (lambda (clause)
175 (unless (or (symbolp clause)
176 (and (consp clause)
177 (symbolp (car clause))
178 (or (null (cdr clause))
179 (null (cddr clause))
180 (null (cdddr clause)))))
181 (error 'malformed-variable-clause
182 :found clause)))
183 variable-clauses))
185 (defun extract-bindings (variable-clauses)
186 (local-mapcar
187 (lambda (clause)
188 (cond ((symbolp clause) clause)
189 ((null (cdr clause)) (car clause))
190 (t (list (car clause) (cadr clause)))))
191 variable-clauses))
193 (defun extract-updates (variable-clauses)
194 (if (null variable-clauses) '()
195 (let ((clause (car variable-clauses)))
196 (if (and (consp clause)
197 (not (null (cddr clause))))
198 (list* (car clause)
199 (caddr clause)
200 (extract-updates (cdr variable-clauses)))
201 (extract-updates (cdr variable-clauses))))))
203 (swf-defmacro do (variable-clauses end-test &body body)
204 ;; do some syntax checking
205 (check-variable-clauses variable-clauses)
206 (unless (proper-list-p body)
207 (error 'malformed-body :body body))
208 (unless (and (proper-list-p end-test)
209 (not (null end-test)))
210 (error 'malformed-end-test :found end-test))
211 (multiple-value-bind (declarations forms)
212 (split-body body)
213 (let ((start-tag (gensym)))
214 `(block nil
215 (let ,(extract-bindings variable-clauses)
216 ,@declarations
217 (tagbody
218 ,start-tag
219 (when ,(car end-test)
220 (return
221 (progn ,@(cdr end-test))))
222 ,@forms
223 (psetq ,@(extract-updates variable-clauses))
224 (go ,start-tag)))))))
226 (swf-defmacro do* (variable-clauses end-test &body body)
227 ;; do some syntax checking
228 (check-variable-clauses variable-clauses)
229 (unless (proper-list-p body)
230 (error 'malformed-body :body body))
231 (unless (and (proper-list-p end-test)
232 (not (null end-test)))
233 (error 'malformed-end-test :found end-test))
234 (multiple-value-bind (declarations forms)
235 (split-body body)
236 (let ((start-tag (gensym)))
237 `(block nil
238 (let* ,(extract-bindings variable-clauses)
239 ,@declarations
240 (tagbody
241 ,start-tag
242 (when ,(car end-test)
243 (return
244 (progn ,@(cdr end-test))))
245 ,@forms
246 (setq ,@(extract-updates variable-clauses))
247 (go ,start-tag))))))))
250 #+nil(dump-defun-asm ()
251 (let (temp)
252 (dolist (a (cons "a" (cons "b" (cons "c" nil)))
253 temp)
254 (%set-local temp (+ temp (:to-string a))))))