movitz.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2002-2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      movitz.lisp
   7 ;;;; Description:
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Mon Oct  9 20:52:58 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: movitz.lisp,v 1.12 2007/03/13 20:40:10 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package movitz)
  17
  18 (defvar *i* nil)                        ; These hold the previous built images,
  19 (defvar *ii* nil)                       ; for interactive use.
  20
  21 (defvar *image* nil)
  22
  23 (define-symbol-macro *movitz-nil*
  24     (image-nil-object *image*))
  25
  26 (define-unsigned lu16 2 :little-endian)
  27 (define-unsigned lu32 4 :little-endian)
  28
  29 (defconstant +code-vector-word-offset+ 2)
  30 (defconstant +code-vector-transient-word+
  31     (ldb (byte 32 0)
  32          (- +code-vector-word-offset+)))
  33
  34 (defvar +movitz-multiple-values-limit+ 63)
  35
  36 (defvar *bq-level* 0)
  37 (defvar *default-image-init-file* #p"losp/los0.lisp")
  38 (defvar *default-image-file* #p"los0-image")
  39
  40 (defvar *movitz-host-features* *features*
  41   "The *features* of the host implementation.")
  42
  43 (defmacro with-host-environment (options &body body)
  44   "Execute body in a `normal' host environment."
  45   (declare (ignore options))
  46   `(let ((*features* *movitz-host-features*))
  47      ,@body))
  48
  49 (defmacro print-unreadable-movitz-object ((object stream &rest key-args) &body body)
  50   "Just like print-unreadable-object, just adorn output so as to
  51 make clear it's a Movitz object, with extra <..>"
  52   (let ((stream-var (gensym "unreadable-movitz-stream-")))
  53     `(let ((,stream-var ,stream))
  54        (print-unreadable-object (,object ,stream-var ,@key-args)
  55          (write-char #\< ,stream-var)
  56          ,@body
  57          (write-char #\> ,stream-var)))))
  58
  59 (defun movitz-syntax-sharp-dot (stream subchar arg)
  60   (declare (ignore arg subchar))
  61   (let ((form (read stream t nil t)))
  62     (values (unless *read-suppress*
  63               (eval (muerte::translate-program form :muerte.cl :cl))))))
  64
  65 (defmacro with-movitz-syntax (options &body body)
  66   (declare (ignore options))
  67   `(let ((*readtable* (copy-readtable)))
  68      (set-dispatch-macro-character #\# #\'
  69                                    (lambda (stream subchar arg)
  70                                      (declare (ignore subchar arg))
  71                                      (list 'muerte.common-lisp::function
  72                                            (read stream t nil t))))
  73      (set-dispatch-macro-character #\# #\{
  74                                    (lambda (stream subchar arg)
  75                                      (declare (ignore subchar arg))
  76                                      (let ((data (read-delimited-list #\} stream)))
  77                                        (make-movitz-vector (length data)
  78                                                            :element-type 'movitz-unboxed-integer-u8
  79                                                            :initial-contents data))))
  80      (set-dispatch-macro-character #\# #\. (lambda (stream subchar arg)
  81                                              (declare (ignore arg subchar))
  82                                              (let ((form (read stream t nil t)))
  83                                                (values (unless *read-suppress*
  84                                                          (eval (muerte::translate-program form :muerte.cl :cl)))))))
  85      (set-macro-character #\` (lambda (stream char)
  86                                 (declare (ignore char))
  87                                 (let ((*bq-level* (1+ *bq-level*)))
  88                                   (list 'muerte::movitz-backquote (read stream t nil t)))))
  89      (set-macro-character #\, (lambda (stream char)
  90                                 (declare (ignore char))
  91                                 (assert (plusp *bq-level*) ()
  92                                   "Comma not inside backquote.")
  93                                 (let* ((next-char (read-char stream t nil t))
  94                                        (comma-type (case next-char
  95                                                      (#\@ 'backquote-comma-at)
  96                                                      (#\. 'backquote-comma-dot)
  97                                                      (t (unread-char next-char stream)
  98                                                         'backquote-comma))))
  99                                   (list comma-type (read stream t nil t)))))
 100      ,@body))
 101
 102 (defun un-backquote (form level)
 103   "Dont ask.."
 104   (declare (notinline un-backquote))
 105   (assert (not (minusp level)))
 106   (values
 107    (typecase form
 108      (null nil)
 109      (list
 110       (case (car form)
 111         (backquote-comma
 112          (cadr form))
 113         (t (cons 'append
 114                  (loop for sub-form-head on form
 115                      as sub-form = (and (consp sub-form-head)
 116                                         (car sub-form-head))
 117                      collecting
 118                        (cond
 119                         ((atom sub-form-head)
 120                          (list 'quote sub-form-head))
 121                         ((atom sub-form)
 122                          (list 'quote (list sub-form)))
 123                         (t (case (car sub-form)
 124                              (muerte::movitz-backquote
 125                               (list 'list
 126                                     (list 'list (list 'quote 'muerte::movitz-backquote)
 127                                           (un-backquote (cadr sub-form) (1+ level)))))
 128                              (backquote-comma
 129                               (cond
 130                                ((= 0 level)
 131                                 (list 'list (cadr sub-form)))
 132                                ((and (listp (cadr sub-form))
 133                                      (eq 'backquote-comma-at (caadr sub-form)))
 134                                 (list 'append
 135                                       (list 'mapcar
 136                                             '(lambda (x) (list 'backquote-comma x))
 137                                             (cadr (cadr sub-form)))))
 138                                (t (list 'list
 139                                         (list 'list
 140                                               (list 'quote 'backquote-comma)
 141                                               (un-backquote (cadr sub-form) (1- level)))))))
 142                              (backquote-comma-at
 143                               (if (= 0 level)
 144                                   (cadr sub-form)
 145                                 (list 'list
 146                                       (list 'list
 147                                             (list 'quote 'backquote-comma-at)
 148                                             (un-backquote (cadr sub-form) (1- level))))))
 149                              (t (list 'list (un-backquote sub-form level))))))
 150                      when (not (listp (cdr sub-form-head)))
 151                      collect (list 'quote (cdr sub-form-head)))
 152                  ))))
 153      (array
 154       (error "Array backquote not implemented."))
 155      (t (list 'quote form)))))
 156
 157 (defmacro muerte::movitz-backquote (form)
 158   (un-backquote form 0))
 159
 160 #+allegro
 161 (excl:defsystem :movitz ()
 162   (:serial
 163    "movitz"
 164    "parse"
 165    "eval"
 166    "multiboot"
 167    "bootblock"
 168    "environment"
 169    "compiler-types"
 170    (:definitions "compiler-protocol"
 171        "storage-types")
 172    "image"
 173    "stream-image"
 174    "procfs-image"
 175    "assembly-syntax"
 176    (:definitions "compiler-protocol"
 177        (:parallel "compiler" "special-operators" "special-operators-cl"))))
 178
 179 #+allegro
 180 (progn
 181   (defun muerte.common-lisp::package-name (package)
 182     (package-name package))
 183   (defun muerte.cl:find-package (name)
 184     (find-package name)))