1 ;;;;------------------------------------------------------------------
3 ;;;; Copyright (C) 20012000, 2002-2004,
4 ;;;; Department of Computer Science, University of Tromso, Norway
6 ;;;; Filename: movitz.lisp
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.
12 ;;;; $Id: movitz.lisp,v 1.12 2007/03/13 20:40:10 ffjeld Exp $
14 ;;;;------------------------------------------------------------------
18 (defvar *i
* nil
) ; These hold the previous built images,
19 (defvar *ii
* nil
) ; for interactive use.
23 (define-symbol-macro *movitz-nil
*
24 (image-nil-object *image
*))
26 (define-unsigned lu16
2 :little-endian
)
27 (define-unsigned lu32
4 :little-endian
)
29 (defconstant +code-vector-word-offset
+ 2)
30 (defconstant +code-vector-transient-word
+
32 (- +code-vector-word-offset
+)))
34 (defvar +movitz-multiple-values-limit
+ 63)
37 (defvar *default-image-init-file
* #p
"losp/los0.lisp")
38 (defvar *default-image-file
* #p
"los0-image")
40 (defvar *movitz-host-features
* *features
*
41 "The *features* of the host implementation.")
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
*))
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
)
57 (write-char #\
> ,stream-var
)))))
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
))))))
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
)
99 (list comma-type
(read stream t nil t
)))))
102 (defun un-backquote (form level
)
104 (declare (notinline un-backquote
))
105 (assert (not (minusp level
)))
114 (loop for sub-form-head on form
115 as sub-form
= (and (consp sub-form-head
)
119 ((atom sub-form-head
)
120 (list 'quote sub-form-head
))
122 (list 'quote
(list sub-form
)))
123 (t (case (car sub-form
)
124 (muerte::movitz-backquote
126 (list 'list
(list 'quote
'muerte
::movitz-backquote
)
127 (un-backquote (cadr sub-form
) (1+ level
)))))
131 (list 'list
(cadr sub-form
)))
132 ((and (listp (cadr sub-form
))
133 (eq 'backquote-comma-at
(caadr sub-form
)))
136 '(lambda (x) (list 'backquote-comma x
))
137 (cadr (cadr sub-form
)))))
140 (list 'quote
'backquote-comma
)
141 (un-backquote (cadr sub-form
) (1- level
)))))))
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
)))
154 (error "Array backquote not implemented."))
155 (t (list 'quote form
)))))
157 (defmacro muerte
::movitz-backquote
(form)
158 (un-backquote form
0))
161 (excl:defsystem
:movitz
()
170 (:definitions
"compiler-protocol"
176 (:definitions
"compiler-protocol"
177 (:parallel
"compiler" "special-operators" "special-operators-cl"))))
181 (defun muerte.common-lisp
::package-name
(package)
182 (package-name package
))
183 (defun muerte.cl
:find-package
(name)
184 (find-package name
)))