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   (swf-defmacro dolist ((var list-form &optional result-form) &body body)
 107     (progn;; do some syntax checking
 108       (unless (symbolp var)
 109         (error 'expected-symbol :found var))
 110       (unless (proper-list-p body)
 111         (error 'malformed-body :body body))
 112       (multiple-value-bind (declarations forms)
 113           (split-body body)
 114         (let ((start-tag (gensym "START"))
 115               (end-tag (gensym "END"))
 116               (list-var (gensym "LIST-VAR")))
 117           `(let ((,list-var ,list-form))
 118              (block nil
 119                (tagbody
 120                   ,start-tag
 121                   (when (endp ,list-var)
 122                     (go ,end-tag))
 123                   (let ((,var (car ,list-var)))
 124                     ,@declarations
 125                     (tagbody ,@forms))
 126                   (pop ,list-var)
 127                   (go ,start-tag)
 128                   ,end-tag)
 129                (let ((,var nil))
 130                  #+nil(declare (ignorable ,var))
 131                  ,result-form)))))))
 132
 133 ;;; For dotimes, we don't have the problem of initial value which is
 134 ;;; always 0, so we can bind the variable once for the entire loop
 135 ;;; body.
 136
 137   (swf-defmacro dotimes ((var count-form &optional result-form) &body body)
 138     ;; do some syntax checking
 139     (unless (symbolp var)
 140       (error 'expected-symbol :found var))
 141     (unless (proper-list-p body)
 142       (error 'malformed-body :body body))
 143     (multiple-value-bind (declarations forms)
 144         (split-body body)
 145       (let ((start-tag (gensym))
 146             (end-tag (gensym))
 147             (count-var (gensym)))
 148         `(let ((,count-var ,count-form)
 149                (,var 0))
 150            #+nil(declare (type integer ,var))
 151            ,@declarations
 152            (block nil
 153              (tagbody
 154                 ,start-tag
 155                 (when (= ,var ,count-var)
 156                   (go ,end-tag))
 157                 (tagbody ,@forms)
 158                 (incf ,var)
 159                 (go ,start-tag)
 160                 ,end-tag)
 161              (let ((,var nil))
 162                #+nil(declare (ignorable ,var))
 163                ,result-form))))))
 164
 165   (defun check-variable-clauses (variable-clauses)
 166     (unless (proper-list-p variable-clauses)
 167       (error 'malformed-variable-clauses :found variable-clauses))
 168     (local-mapcar
 169      (lambda (clause)
 170        (unless (or (symbolp clause)
 171                    (and (consp clause)
 172                         (symbolp (car clause))
 173                         (or (null (cdr clause))
 174                             (null (cddr clause))
 175                             (null (cdddr clause)))))
 176          (error 'malformed-variable-clause
 177                 :found clause)))
 178      variable-clauses))
 179
 180   (defun extract-bindings (variable-clauses)
 181     (local-mapcar
 182      (lambda (clause)
 183        (cond ((symbolp clause) clause)
 184              ((null (cdr clause)) (car clause))
 185              (t (list (car clause) (cadr clause)))))
 186      variable-clauses))
 187
 188   (defun extract-updates (variable-clauses)
 189     (if (null variable-clauses) '()
 190         (let ((clause (car variable-clauses)))
 191           (if (and (consp clause)
 192                    (not (null (cddr clause))))
 193               (list* (car clause)
 194                      (caddr clause)
 195                      (extract-updates (cdr variable-clauses)))
 196               (extract-updates (cdr variable-clauses))))))
 197
 198   #+nil(swf-defmacro do (variable-clauses end-test &body body)
 199     ;; do some syntax checking
 200     (check-variable-clauses variable-clauses)
 201     (unless (proper-list-p body)
 202       (error 'malformed-body :body body))
 203     (unless (and (proper-list-p end-test)
 204                  (not (null end-test)))
 205       (error 'malformed-end-test :found end-test))
 206     (multiple-value-bind (declarations forms)
 207         (split-body body)
 208       (let ((start-tag (gensym)))
 209         `(block nil
 210            (let ,(extract-bindings variable-clauses)
 211              ,@declarations
 212              (tagbody
 213                 ,start-tag
 214                 (when ,(car end-test)
 215                   (return
 216                     (progn ,@(cdr end-test))))
 217                 ,@forms
 218                 (psetq ,@(extract-updates variable-clauses))
 219                 (go ,start-tag)))))))
 220
 221   #+nil(defmacro do* (variable-clauses end-test &body body)
 222     ;; do some syntax checking
 223     (check-variable-clauses variable-clauses)
 224     (unless (proper-list-p body)
 225       (error 'malformed-body :body body))
 226     (unless (and (proper-list-p end-test)
 227                  (not (null end-test)))
 228       (error 'malformed-end-test :found end-test))
 229     (multiple-value-bind (declarations forms)
 230         (split-body body)
 231       (let ((start-tag (gensym)))
 232         `(block nil
 233            (let* ,(extract-bindings variable-clauses)
 234              ,@declarations
 235              (tagbody
 236                 ,start-tag
 237                 (when ,(car end-test)
 238                   (return
 239                     (progn ,@(cdr end-test))))
 240                 ,@forms
 241                 (setq ,@(extract-updates variable-clauses))
 242                 (go ,start-tag))))))))
 243
 244
 245 #+nil(dump-defun-asm ()
 246   (let (temp)
 247     (dolist (a (cons "a" (cons "b" (cons "c" nil)))
 248              temp)
 249       (%set-local temp (+ temp (:to-string  a))))))