losp/muerte/more-macros.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      more-macros.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Fri Jun  7 15:05:57 2002
  12 ;;;;
  13 ;;;; $Id: more-macros.lisp,v 1.36 2006/05/06 20:31:23 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/setf)
  18 (provide :muerte/more-macros)
  19
  20 (in-package muerte)
  21
  22 (defmacro pop (&environment env place)
  23   (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)
  24       (get-setf-expansion place env)
  25     (assert (= 1 (length store-vars)) ()
  26       "Can't pop a place with ~D cells." (length store-vars))
  27     (let ((store-var (first store-vars)))
  28       `(let ,(mapcar #'list tmp-vars tmp-var-init-forms)
  29          (let ((,store-var ,getter-form))
  30            (prog1
  31                (car ,store-var)
  32              (setq ,store-var (cdr ,store-var))
  33              ,setter-form))))))
  34
  35 (define-compiler-macro pop (&whole form &environment env place)
  36   (if (and (symbolp place)
  37            (typep (movitz::movitz-binding place env) 'movitz::lexical-binding))
  38       `(with-inline-assembly (:returns :ebx)
  39          (:compile-form (:result-mode :eax) ,place)
  40          (:globally (:call (:edi (:edi-offset fast-cdr-car))))
  41          (:lexical-store ,place :eax))
  42       #+ignore
  43       `(prog1 (car ,place)
  44          (setq ,place (cdr ,place)))
  45     form))
  46
  47 (defmacro push (&environment env item place)
  48   (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)
  49       (get-setf-expansion place env)
  50     (assert (= 1 (length store-vars)) ()
  51       "Can't push a place with ~D cells." (length store-vars))
  52     (let ((store-var (first store-vars))
  53           (item-var (gensym "push-item-")))
  54       `(let ((,item-var ,item)
  55              ,@(mapcar #'list tmp-vars tmp-var-init-forms))
  56          (let ((,store-var (cons ,item-var ,getter-form)))
  57            ,setter-form)))))
  58
  59 #+ignore
  60 (define-compiler-macro push (&whole form &environment env item place)
  61   (if (and (symbolp place)
  62            (not (typep (movitz::movitz-binding place env) 'movitz::symbol-macro-binding)))
  63       `(setq ,place (cons ,item ,place))
  64     form))
  65
  66 (defmacro pushnew (&environment env item place &rest key-test-args)
  67   (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)
  68       (get-setf-expansion place env)
  69     (assert (= 1 (length store-vars)) ()
  70       "Can't pushnew a place with ~D cells." (length store-vars))
  71     (let ((store-var (first store-vars))
  72           (item-var (gensym "push-item-")))
  73       `(let ((,item-var ,item)
  74              ,@(mapcar #'list tmp-vars tmp-var-init-forms))
  75          (let ((,store-var (adjoin ,item-var ,getter-form ,@key-test-args)))
  76            ,setter-form)))))
  77
  78 (defmacro remf (&environment env place indicator)
  79   (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)
  80       (get-setf-expansion place env)
  81     (assert (= 1 (length store-vars)) ()
  82       "Can't remf a place with ~D cells." (length store-vars))
  83     (let ((store-var (first store-vars))
  84           (indicator-var (gensym "remf-indicator-")))
  85       `(let (,@(mapcar #'list tmp-vars tmp-var-init-forms)
  86              (,indicator-var ,indicator))
  87          (let ((p ,getter-form))
  88            (cond
  89             ((null p) nil)
  90             ((eq ,indicator-var (car p))
  91              (let ((,store-var (cddr p)))
  92                ,setter-form)
  93              t)
  94             (t (do ((x (cdr p) (cddr x))
  95                     (y (cddr p) (cddr y)))
  96                    ((null y) nil)
  97                  (when (eq ,indicator-var (car y))
  98                    (setf (cdr x) (cddr y))
  99                    (return t))))))))))
 100
 101 (define-compiler-macro dotimes (&whole form-decline (var count-form &optional result-form)
 102                                 &body declarations-and-body &environment env)
 103   (if (not (movitz:movitz-constantp count-form env))
 104       form-decline
 105     (let ((count (movitz:movitz-eval count-form env)))
 106       (check-type count (integer 0 *))
 107       (cond
 108        ((= 0 count)
 109         nil)
 110        ((= 1 count)
 111         `(let ((,var 0))
 112            ,@declarations-and-body
 113            ,result-form))
 114        (t `(do ((,var 0 (1+ ,var)))
 115                ((>= ,var ,count) ,result-form)
 116              (declare (type (integer 0 ,count) ,var))
 117              ,@declarations-and-body))))))
 118
 119 (defmacro dotimes ((var count-form &optional result-form) &body declarations-and-body)
 120   (let ((count-var (gensym)))
 121     `(do ((,count-var ,count-form)
 122           (,var 0 (1+ ,var)))
 123          ((<= ,count-var ,var) ,result-form)
 124        ,@declarations-and-body)))
 125
 126 (defmacro dolist ((var list-form &optional result-form) &body declarations-and-body)
 127   (let ((cons-var (gensym "dolist-cons-")))
 128     `(do ((,cons-var ,list-form))
 129          ((null ,cons-var) ,result-form)
 130        (let ((,var (pop ,cons-var)))
 131          ,@declarations-and-body))))
 132
 133 (define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql)
 134                                &environment env)
 135   (let* ((test (or (and (movitz:movitz-constantp test env)
 136                         (translate-program (movitz:movitz-eval test env) :muerte.cl :cl))
 137                    (and (consp test) (eq 'function (car test))
 138                         (cadr test))))
 139          (key (or (and (movitz:movitz-constantp key env)
 140                        (translate-program (movitz:movitz-eval key env) :muerte.cl :cl))
 141                   (and (consp key) (eq 'function (car key))
 142                        (cadr key)))))
 143     (cond
 144      ((and test (symbolp test) (eq key 'identity))
 145       `(do ((item ,item)
 146             (p ,list (cdr p)))
 147            ((endp p) nil)
 148          (when (,test item (car p))
 149            (return p))))
 150      ((and test (symbolp test)
 151            key (symbolp key))
 152       `(do ((item ,item)
 153             (p ,list (cdr p)))
 154            ((endp p) nil)
 155          (when (,test (,key item) (,key (car p)))
 156            (return p))))
 157      (t form))))
 158
 159 (defmacro letf* (bindings &body body &environment env)
 160   "Does what one might expect, saving the old values and setting the generalized
 161   variables to the new values in sequence.  Unwind-protects and get-setf-method
 162   are used to preserve the semantics one might expect in analogy to let*,
 163   and the once-only evaluation of subforms."
 164   (labels ((do-bindings
 165             (bindings)
 166             (cond ((null bindings) body)
 167                   (t (multiple-value-bind (dummies vals newval setter getter)
 168                          (get-setf-expansion (caar bindings) env)
 169                        (let ((save (gensym)))
 170                          `((let* (,@(mapcar #'list dummies vals)
 171                                   (,(car newval) ,(cadar bindings))
 172                                   (,save ,getter))
 173                              (unwind-protect
 174                                (progn ,setter
 175                                       ,@(do-bindings (cdr bindings)))
 176                                (setq ,(car newval) ,save)
 177                                ,setter)))))))))
 178     (car (do-bindings bindings))))
 179
 180 (defmacro with-letf (clauses &body body)
 181   "Each clause is (<place> &optional <value-form> <prev-var>).
 182 Execute <body> with alternative values for each <place>.
 183 Note that this scheme does not work well with respect to multiple threads.
 184 XXX This should actually be using get-setf-expansion etc. to deal with
 185 proper evaluation of the places' subforms."
 186   (let ((place-value-save (loop for (place . value-save) in clauses
 187                               if value-save
 188                               collect (list place `(progn ,(first value-save))
 189                                             (or (second value-save) (gensym)))
 190                               else collect (list place nil (gensym)))))
 191     `(let (,@(loop for (place nil save-var) in place-value-save
 192                  collect `(,save-var ,place)))
 193        (unwind-protect
 194            (progn (setf ,@(loop for (place value) in place-value-save
 195                               append `(,place ,value)))
 196                   ,@body)
 197          (setf ,@(loop for (place nil save) in place-value-save
 198                      append `(,place ,save)))))))
 199
 200 (defmacro with-alternative-fdefinitions (clauses &body body)
 201   "Each clause is (<name> <definition>). Execute <body> with alternative
 202 fdefinitions for each <name>. Note that this scheme does not work well with
 203 respect to multiple threads."
 204   (let ((tmp-name-def (loop for (name def) in clauses
 205                           collect (list (gensym) name def))))
 206     `(let (,@(loop for (tmp name) in tmp-name-def collect `(,tmp (fdefinition ',name))))
 207        (macrolet ((previous-fdefinition (&whole form name)
 208                     (case name
 209                       ,@(loop for (tmp name) in tmp-name-def
 210                             collect `(,name ',tmp))
 211                       (t form))))
 212          (unwind-protect
 213              (progn (setf ,@(loop for (nil name def) in tmp-name-def
 214                                 append `((fdefinition ',name) ,def)))
 215                     ,@body)
 216            (setf ,@(loop for (tmp name) in tmp-name-def
 217                        append `((fdefinition ',name) ,tmp))))))))
 218
 219 (defmacro eof-or-lose (stream eof-errorp eof-value)
 220   `(if ,eof-errorp
 221        (error 'end-of-file :stream ,stream)
 222        ,eof-value))
 223
 224 (defmacro handler-bind (bindings &body forms)
 225   (if (null bindings)
 226       `(progn ,@forms)
 227     (labels ((make-handler (binding)
 228                (destructuring-bind (type handler)
 229                    binding
 230                  `(cons ',type ,handler))))
 231       (let ((scope-tag (gensym "handler-bind-extent-scope-")))
 232         `(with-dynamic-extent-scope (,scope-tag)
 233            (let ((*active-condition-handlers*
 234                   (with-dynamic-extent-allocation (,scope-tag)
 235                     (cons (list ,@(mapcar #'make-handler bindings))
 236                           *active-condition-handlers*))))
 237              ,@forms))))))
 238
 239 (defmacro handler-case (expression &rest clauses)
 240   (multiple-value-bind (normal-clauses no-error-clauses)
 241       (loop for clause in clauses
 242           if (eq :no-error (car clause))
 243           collect clause into no-error-clauses
 244           else collect clause into normal-clauses
 245           finally (return (values normal-clauses no-error-clauses)))
 246     (case (length no-error-clauses)
 247       (0 (let ((block-name (gensym "handler-case-block-"))
 248                (var-name (gensym "handler-case-var-"))
 249                (temp-name (gensym "handler-case-temp-var-"))
 250                (specs (mapcar (lambda (clause)
 251                                 (list clause (gensym "handler-case-clause-tag-")))
 252                               normal-clauses)))
 253            `(block ,block-name
 254               (let (,var-name)
 255                 (tagbody
 256                   (handler-bind ,(mapcar (lambda (clause-spec)
 257                                            (let* ((clause (first clause-spec))
 258                                                   (go-tag (second clause-spec))
 259                                                   (typespec (first clause)))
 260                                              `(,typespec (lambda (,temp-name)
 261                                                            (setq ,var-name ,temp-name)
 262                                                            (go ,go-tag)))))
 263                                   specs)
 264                     (return-from ,block-name ,expression))
 265                   ,@(mapcan (lambda (clause-spec)
 266                               (let* ((clause (first clause-spec))
 267                                      (go-tag (second clause-spec))
 268                                      (var (first (second clause)))
 269                                      (body (cddr clause)))
 270                                 (if (not var)
 271                                     `(,go-tag (return-from ,block-name
 272                                                 (let () ,@body)))
 273                                   `(,go-tag (return-from ,block-name
 274                                               (let ((,var ,var-name))
 275                                                 ,@body))))))
 276                             specs))))))
 277       (t (error "Too many no-error clauses.")))))
 278
 279 (defmacro ignore-errors (&body body)
 280   `(handler-case (progn ,@body)
 281      (error (c) (values nil c))))
 282
 283 (defmacro with-accessors (slot-entries instance-form &body declarations-and-forms)
 284   (let ((instance-variable (gensym "with-accessors-instance-")))
 285     `(let ((,instance-variable ,instance-form))
 286        (declare (ignorable ,instance-variable))
 287        (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries
 288                              collecting `(,variable-name (,accessor-name ,instance-variable)))
 289          ,@declarations-and-forms))))
 290
 291 (defmacro with-slots (slot-entries instance-form &body declarations-and-forms)
 292   (let ((object-var (gensym "with-slots-object-")))
 293     `(symbol-macrolet ,(mapcar (lambda (entry)
 294                                  (let ((var (if (atom entry) entry (car entry)))
 295                                        (slot (if (atom entry) entry (cadr entry))))
 296                                    `(,var (slot-value ,object-var ',slot))))
 297                                slot-entries)
 298        (let ((,object-var ,instance-form))
 299          ,@declarations-and-forms))))
 300
 301
 302 (define-compiler-macro %bignum-bigits (x)
 303   `(with-inline-assembly (:returns :eax :type (unsigned-byte 14))
 304      (:compile-form (:result-mode :eax) ,x)
 305      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 306               :eax)
 307      (:testb 3 :al)                     ; Just to be sure..
 308      (:jnz '(:sub-program () (:int 63)))))
 309
 310 (defmacro with-simple-restart ((name format-control &rest format-arguments)
 311                                             &body body)
 312   `(with-basic-restart (,name 'with-simple-restart nil nil
 313                               ,format-control ,@format-arguments)
 314      ,@body))
 315
 316 (define-compiler-macro %run-time-context-slot (&whole form &environment env context slot-name)
 317   (if (not (movitz:movitz-constantp slot-name env))
 318       form
 319     (let* ((slot-name (movitz::eval-form slot-name env))
 320            (slot-type (bt:binary-slot-type 'movitz::movitz-run-time-context
 321                                            (intern (symbol-name slot-name) :movitz))))
 322       (if (or (and (movitz:movitz-constantp context env)
 323                    (eq nil (movitz:movitz-eval context env)))
 324               (equal context '(current-run-time-context)))
 325           (ecase slot-type
 326             (movitz::word
 327              `(with-inline-assembly (:returns :eax)
 328                 (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))))
 329             (movitz::code-vector-word
 330              `(with-inline-assembly (:returns :eax)
 331                 (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax)
 332                 (:locally (:addl (:edi (:edi-offset ,slot-name)) :eax))))
 333             (movitz::lu32
 334              `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 335                 (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx)))))
 336         (ecase slot-type
 337           (movitz::word
 338            `(with-inline-assembly (:returns :eax)
 339               (:compile-form (:result-mode :eax) ,context)
 340               (,movitz:*compiler-nonlocal-lispval-read-segment-prefix*
 341                :movl (:eax :edi (:offset movitz-run-time-context ,slot-name
 342                                          ,(- (movitz:tag :other)))) :eax)))
 343           (movitz::code-vector-word
 344            `(with-inline-assembly (:returns :eax)
 345               (:compile-form (:result-mode :eax) ,context)
 346               (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax)
 347               (,movitz:*compiler-nonlocal-lispval-read-segment-prefix*
 348                :addl (:eax :edi (:offset movitz-run-time-context ,slot-name
 349                                          ,(- (movitz:tag :other)))) :eax)))
 350           (movitz::lu32
 351            `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 352               (:compile-form (:result-mode :eax) ,context)
 353               (,movitz:*compiler-nonlocal-lispval-read-segment-prefix*
 354                :movl (:eax :edi (:offset movitz-run-time-context ,slot-name
 355                                          ,(- (movitz:tag :other)))) :ecx))))))))
 356
 357
 358 (define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value context slot-name)
 359   (if (not (movitz:movitz-constantp slot-name env))
 360       form
 361     (let* ((slot-name (movitz::eval-form slot-name env))
 362            (slot-type (bt:binary-slot-type 'movitz::movitz-run-time-context
 363                                            (intern (symbol-name slot-name) :movitz))))
 364       (if (or (and (movitz:movitz-constantp context env)
 365                    (eq nil (movitz:movitz-eval context env)))
 366               (equal context '(current-run-time-context)))
 367           (ecase slot-type
 368             (movitz:word
 369              `(with-inline-assembly (:returns :eax)
 370                 (:compile-form (:result-mode :eax) ,value)
 371                 (:locally (:movl :eax (:edi (:edi-offset ,slot-name))))))
 372             (movitz:lu32
 373              `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 374                 (:compile-form (:result-mode :untagged-fixnum-ecx) ,value)
 375                 (:locally (:movl :ecx (:edi (:edi-offset ,slot-name))))))
 376             (movitz:code-vector-word
 377              `(with-inline-assembly (:returns :eax)
 378                 (:compile-form (:result-mode :eax) ,value)
 379                 (:leal (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx)
 380                 (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))))
 381         ;; FIXME
 382         form))))
 383
 384 (define-compiler-macro read-time-stamp-counter ()
 385   `(with-inline-assembly-case ()
 386      (do-case (:register :same)
 387        (:std)
 388        (:rdtsc)
 389        (:movl :edi :edx)
 390        (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) (:result-register))
 391        (:cld))
 392      (do-case (t :multiple-values)
 393        (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter)))))
 394
 395 (defmacro without-interrupts (&body body)
 396   (let ((var (gensym "interrupts-enabled-p-")))
 397     `(let ((,var (logbitp ,(position :if (symbol-value '+eflags-map+)) (eflags))))
 398        (unwind-protect (progn (cli) ,@body)
 399          (when ,var (sti))))))
 400
 401
 402 (define-compiler-macro dit-frame-ref (&whole form stack frame reg
 403                                       &optional (type :lisp)
 404                                       &environment env)
 405   (if (not (and (movitz:movitz-constantp stack env)
 406                 (eq nil (movitz:movitz-eval stack env))))
 407       form
 408     `(memref ,frame (dit-frame-offset ,reg) :type ,type)))
 409
 410 (define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg
 411                                              &optional (type :lisp)
 412                                              &environment env)
 413   (if (not (and (movitz:movitz-constantp stack env)
 414                 (eq nil (movitz:movitz-eval stack env))))
 415       form
 416     `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value)))
 417
 418 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 419
 420 (defmacro define-unimplemented-macro (name)
 421   `(defmacro ,name (&rest args)
 422      (declare (ignore args))
 423      (with-simple-restart (continue "Proceed with a NIL expansion for ~S." ',name)
 424        (error "Macro ~S is not implemented yet." ',name))))
 425
 426 (define-unimplemented-macro with-open-file)
 427 (define-unimplemented-macro restart-case)
 428
 429 (defmacro load (filespec &key verbose print if-does-not-exist external-format)
 430   "hm..."
 431   (assert (movitz:movitz-constantp filespec) (filespec)
 432     "Can't load a non-constant filename: ~S" filespec)
 433   (warn "load-compile: ~S" filespec)
 434   `(funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec))))
 435
 436 (defmacro locally (&body body)
 437   `(let () ,@body))
 438
 439 (defmacro with-standard-io-syntax (&body body)
 440   `(let ((*package* (find-package :init))
 441          (*print-array* t)
 442          (*print-base* 10)
 443          (*print-case* :upcase)
 444          (*print-circle* nil)
 445          (*print-escape* t)
 446          (*print-gensym* t)
 447          (*print-length* nil)
 448          (*print-level* nil)
 449          (*print-lines* nil)
 450          #+ignore (*print-miser-width* nil)
 451          #+ignore (*print-pprint-dispatch* nil)
 452          (*print-pretty* nil)
 453          (*print-radix* nil)
 454          (*print-readably* t)
 455          #+ignore (*print-right-margin* nil)
 456          (*read-base* 10)
 457          (*read-default-float-format* 'ratio)
 458          (*read-eval* t)
 459          (*read-suppress* nil)
 460          #+ignore (*readtable* nil))
 461      ,@body))