lib/sicl-iteration.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; pieces of sicl/iteration.lisp that work so far
   4
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;;;
   7 ;;; Conditions
   8
   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))))
  15
  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))))
  24
  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))))
  33
  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))))
  45
  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))))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;;;
  59 ;;; Utilities
  60
  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))))
  68
  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)))))
  74
  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.
  79
  80 (defun local-mapcar (function list)
  81   (if (null list)
  82       '()
  83       (cons (funcall function (car list))
  84             (local-mapcar function (cdr list)))))
  85
  86 (let ((*symbol-table* *cl-symbol-table*))
  87
  88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89 ;;;
  90 ;;; Macros dolist and dotimes
  91
  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.
  98
  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.
 105
 106
 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)))))))
 136
 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.
 140
 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))))))
 169
 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))
 184
 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))
 192
 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))))))
 202
 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)))))))
 225
 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))))))))
 248
 249
 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))))))
 255