(when init
(unless used
(format stream
- " struct ~A *sod__obj = ~
- ~0@*~A__imprint(p);~2%"
- class
- (ilayout-struct-tag class))
+ " struct ~A *sod__obj = ~A__imprint(p);~2%"
+ (ilayout-struct-tag class) class)
(setf used t))
(format stream " ~A.~A =" isl
(sod-slot-name dslot))
};~:^~2%~}
~0@*static const struct sod_chain ~A__chains[] = {
-~:{ { ~3@*~A,
- ~0@*&~A__chain_~A,
- ~4@*offsetof(struct ~A, ~A),
- (const struct sod_vtable *)&~A,
- sizeof(struct ~A) }~:^,~%~}
+~:{ { ~
+ /* n_classes = */ ~3@*~A,
+ /* classes = */ ~0@*~A__chain_~A,
+ /* off_ichain = */ ~4@*offsetof(struct ~A, ~A),
+ /* vt = */ (const struct sod_vtable *)&~A,
+ /* ichainsz = */ sizeof(struct ~A) }~:^,~%~}
};~2%"
class ;0
(mapcar (lambda (chain) ;1
(let* ((head (sod-class-chain-head (car chain)))
+ (tail (sod-class-chain-head (car chain)))
(chain-nick (sod-class-nickname head)))
- (list class chain-nick ;0 1
- (reverse chain) ;2
- (length chain) ;3
- (ilayout-struct-tag class) chain-nick ;4 5
- (vtable-name class head) ;6
- (ichain-struct-tag class head)))) ;7
+ (list class chain-nick ;0 1
+ (reverse chain) ;2
+ (length chain) ;3
+ (ilayout-struct-tag class) chain-nick ;4 5
+ (vtable-name class head) ;6
+ (ichain-struct-tag (car chain) head)))) ;7
chains))))
;;;--------------------------------------------------------------------------
;;; Class-specific layout.
(define-class-slot "off_islots" (class) size-t
- (format nil "offsetof(struct ~A, ~A)"
- (ichain-struct-tag class (sod-class-chain-head class))
- (sod-class-nickname class)))
+ (if (sod-class-slots class)
+ (format nil "offsetof(struct ~A, ~A)"
+ (ichain-struct-tag class (sod-class-chain-head class))
+ (sod-class-nickname class))
+ "0"))
(define-class-slot "islotsz" (class) size-t
- (format nil "sizeof(struct ~A)"
- (islots-struct-tag class)))
+ (if (sod-class-slots class)
+ (format nil "sizeof(struct ~A)"
+ (islots-struct-tag class))
+ "0"))
;;;--------------------------------------------------------------------------
;;; Bootstrapping the class graph.
(defun make-builtin-module ()
"Construct the builtin module.
- This involves constructing the braid (which is done in `bootstrap-classes'
- and defining a few obvious type names which users will find handy.
+ This involves constructing the braid (which is done in
+ `bootstrap-classes') and defining a few obvious type names which users
+ will find handy.
Returns the newly constructed module, and stores it in the variable
`*builtin-module*'."
:type "SOD"
:case :common)
:state nil)))
- (call-with-module-environment
- (lambda ()
- (dolist (name '("va_list" "size_t" "ptrdiff_t"))
- (add-to-module module (make-instance 'type-item :name name)))
- (flet ((header-name (name)
- (concatenate 'string "\"" (string-downcase name) ".h\""))
- (add-includes (reason &rest names)
- (let ((text (with-output-to-string (out)
- (dolist (name names)
- (format out "#include ~A~%" name)))))
- (add-to-module module
- (make-instance 'code-fragment-item
- :reason reason
- :constraints nil
- :name :includes
- :fragment text)))))
- (add-includes :c (header-name "sod"))
- (add-includes :h "<stddef.h>"))
- (bootstrap-classes module)))
+ (with-module-environment (module)
+ (dolist (name '("va_list" "size_t" "ptrdiff_t"))
+ (add-to-module module (make-instance 'type-item :name name)))
+ (flet ((header-name (name)
+ (concatenate 'string "\"" (string-downcase name) ".h\""))
+ (add-includes (reason &rest names)
+ (let ((text (with-output-to-string (out)
+ (dolist (name names)
+ (format out "#include ~A~%" name)))))
+ (add-to-module module
+ (make-instance 'code-fragment-item
+ :reason reason
+ :constraints nil
+ :name :includes
+ :fragment text)))))
+ (add-includes :c (header-name "sod"))
+ (add-includes :h "<stddef.h>"))
+ (bootstrap-classes module))
(setf *builtin-module* module)))
;;;----- That's all, folks --------------------------------------------------
(values it (slot-value it 'tag))
(let* ((tag (gensym "TAG-"))
(type (intern-c-type 'c-class-type :name name :tag tag)))
+ (setf (gethash name *module-type-map*) type)
(values type tag)))
;; If no qualifiers are wanted then we've already found or created the
(argument-list ()
;; [ argument [ `,' argument ]* ]
- (parse (list ()
- (seq ((base-type (parse-c-type scanner))
- (dtor (parse-declarator scanner
- base-type
- :abstractp t)))
- (make-argument (cdr dtor) (car dtor)))
- #\,)))
+ (parse (list (:min 0)
+ (seq ((base-type (parse-c-type scanner))
+ (dtor (parse-declarator scanner
+ base-type
+ :abstractp t)))
+ (make-argument (cdr dtor) (car dtor)))
+ #\,)))
(postfix-lparen ()
;; Postfix: `(' argument-list `)'
;; Check that the arguments are named if we have a method body.
(with-slots (body type) method
(unless (or (not body)
- (every #'argument-name (c-function-arguments type)))
+ (every (lambda (arg)
+ (or (argument-name arg)
+ (eq (argument-type arg) (c-type void))))
+ (c-function-arguments type)))
(error "Abstract declarators not permitted in method definitions")))
;; Check the method type.
sequencer))
(defmethod hook-output progn ((class sod-class) reason sequencer)
- (with-slots (ilayout vtables methods effective-methods) class
+ (with-slots (ilayout vtables methods) class
(hook-output ilayout reason sequencer)
(dolist (method methods) (hook-output method reason sequencer))
- (dolist (method effective-methods)
- (hook-output method reason sequencer))
(dolist (vtable vtables) (hook-output vtable reason sequencer))))
;;;--------------------------------------------------------------------------
(format stream "};~2%"))))
(sequence-output (stream sequencer)
((class :vtable-externs)
- (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
+ (format stream "~@<extern const struct ~A ~2I~_~A__vtable_~A;~:>~%"
(vtable-struct-tag chain-tail chain-head)
class (sod-class-nickname chain-head))))))
(let* ((method (method-entry-effective-method entry))
(message (effective-method-message method))
(class (effective-method-class method))
- (type (method-entry-function-type entry))
- (commented-type (commentify-function-type type)))
+ (function-type (method-entry-function-type entry))
+ (commented-type (commentify-function-type function-type))
+ (pointer-type (make-pointer-type commented-type)))
(sequence-output (stream sequencer)
((class :vtmsgs (sod-message-class message) :slots)
(pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type commented-type stream (sod-message-name message)))
+ (pprint-c-type pointer-type stream (sod-message-name message)))
(terpri stream)))))
(defmethod hook-output progn ((cptr class-pointer)
((class :vtable chain-head :slots)
(format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
metaclass
- (if (sod-class-direct-superclasses meta-chain-head)
- (sod-class-nickname meta-chain-head)
- nil))))))
+ (and (sod-class-direct-superclasses meta-chain-head)
+ (sod-class-nickname meta-chain-head)))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
(with-slots (class chain-head) boff
sequencer)))
;;;--------------------------------------------------------------------------
-;;; Direct methods.
+;;; Direct and effective methods.
(defmethod hook-output progn ((method delegating-direct-method)
(reason (eql :c))
(class :vtables :end))
((class :vtable chain-head :start)
(format stream "/* Vtable for ~A chain. */~@
- static const struct ~A ~A = {~%"
+ const struct ~A ~A = {~%"
chain-head
(vtable-struct-tag chain-tail chain-head)
- (vtable-name chain-tail chain-head)))
+ (vtable-name class chain-head)))
((class :vtable chain-head :end)
(format stream "};~2%")))))
(class :vtable chain-head :class-pointer metaclass)
(class :vtable chain-head :end))
((class :vtable chain-head :class-pointer metaclass)
- (format stream " &~A__classobj.~A.~A,~%"
+ (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
+ (if (sod-class-direct-superclasses meta-chain-head)
+ (format nil "_cls_~A"
+ (sod-class-nickname meta-chain-head))
+ "_class")
(sod-class-metaclass class)
(sod-class-nickname meta-chain-head)
(sod-class-nickname metaclass))))))
(class :vtable chain-head :base-offset)
(class :vtable chain-head :end))
((class :vtable chain-head :base-offset)
- (format stream " offsetof(struct ~A, ~A),~%"
+ (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
+ "_base"
(ilayout-struct-tag class)
(sod-class-nickname chain-head))))))
(class :vtable chain-head :chain-offset target-head)
(class :vtable chain-head :end))
((class :vtable chain-head :chain-offset target-head)
- (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+ (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+ (format nil "_off_~A" (sod-class-nickname target-head))
(ilayout-struct-tag class)
(sod-class-nickname chain-head)
(sod-class-nickname target-head))))))
(super (sod-message-class message)))
(sequence-output (stream sequencer)
((class :vtable chain-head :vtmsgs super :slots)
- (format stream " ~A,~%"
+ (format stream " /* ~19@A = */ ~A,~%"
+ (sod-message-name message)
(method-entry-function-name method chain-head)))))))
;;;--------------------------------------------------------------------------
(defgeneric output-class-initializer (slot instance stream)
(:method ((slot sod-class-effective-slot) (instance sod-class) stream)
- (let ((func (effective-slot-initializer-function slot)))
+ (let ((func (effective-slot-initializer-function slot))
+ (direct-slot (effective-slot-direct-slot slot)))
(if func
- (format stream " ~A,~%" (funcall func instance))
+ (format stream " /* ~15@A = */ ~A,~%"
+ (sod-slot-name direct-slot)
+ (funcall func instance))
(call-next-method))))
(:method ((slot effective-slot) (instance sod-class) stream)
- (let ((init (find-class-initializer slot instance)))
+ (let ((init (find-class-initializer slot instance))
+ (direct-slot (effective-slot-direct-slot slot)))
(ecase (sod-initializer-value-kind init)
- (:simple (format stream " ~A,~%"
+ (:simple (format stream " /* ~15@A = */ ~A,~%"
+ (sod-slot-name direct-slot)
(sod-initializer-value-form init)))
- (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
- (sod-initializer-value-form init)))))))
+ (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
+ (sod-slot-name direct-slot)
+ (sod-initializer-value-form init)))))))
(defmethod hook-output progn ((slot sod-class-effective-slot)
(reason (eql 'class))
This is automatically reset to zero before the output functions are
invoked to write a file. This way, we can ensure that the same output
- file is always produced from the same input."
- ;; FIXME: this is currently a lie. Need some protocol to ensure that this
- ;; happens.
-)
+ file is always produced from the same input.")
+
+(define-clear-the-decks reset-codegen-index
+ (setf *temporary-index* 0))
;; Important temporary names.
"A base class for instructions.
An `instruction' is anything which might be useful to string into a code
- generator. Both statements and expressions map can be represented by
- trees of instructions. The `definst' macro is a convenient way of
- defining new instructions.
+ generator. Both statements and expressions can be represented by trees of
+ instructions. The `definst' macro is a convenient way of defining new
+ instructions.
The only important protocol for instructions is output, which is achieved
by calling `print-object' with `*print-escape*' nil.
This isn't intended to be a particularly rigorous definition. Its purpose
is to allow code generators to make decisions about inlining or calling
code fairly simply.")
- (:method (inst)
+ (:method ((inst t))
+ (declare (ignore inst))
+ 1)
+ (:method ((inst null))
(declare (ignore inst))
- 1))
+ 1)
+ (:method ((inst list))
+ (reduce #'+ inst :key #'inst-metric)))
;; Instruction definition.
"Evaluate BODY with VAR bound to a temporary variable name.
During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
- available for re-use."
+ available for re-use."
`(let ((,var (temporary-var ,codegen ,type)))
(unwind-protect
(progn ,@body)
#! /bin/sh -ex
-
cl-launch -o sod -d "$(pwd)/sod.img" -s sod +I -r sod:main "$@"
/* foo */
-code header : include {
+code c : includes {
#include "foo.h"
}
-lisp (format t "hello, world!~%");
-demo "found foo ok";
+
+code h : includes {
+#include "sod.h"
+}
+
+//[link = SodObject]
+class Test : SodObject {
+ int x = 0;
+
+ int cur() { return me->test.x; }
+ void inc() { me->test.x++; }
+ void dec() { me->test.x--; }
+}
+
+[link = Test, nick = snd]
+class Second : Test {
+ void test.dec() { me->test.x -= 3; }
+}
;;;--------------------------------------------------------------------------
;;; The main program.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defopthandler dirpath (var arg) ()
+ "Convert the argument into a pathname with a directory component
+ and no file component, suitable for merging."
+
+ ;; This is really fiddly and annoying. Unix pathnames don't tell you
+ ;; whether the thing named is meant to be a directory or not, and
+ ;; implementations differ as to how they cope with pathnames which do or
+ ;; don't name directories when they're expecting files, or vice versa.
+
+ (let ((path (ignore-errors (pathname arg))))
+ (cond ((null path)
+ ;; The namestring couldn't be parsed, or something else went
+ ;; horribly wrong.
+
+ (option-parse-error "Can't parse `~A' as a path" arg))
+
+ #+unix
+ ((or (pathname-name path) (pathname-type path))
+ ;; If this is Unix, or similar, then stick the filename piece on
+ ;; the end of the directory and hope that was sensible.
+
+ (setf var (make-pathname
+ :name nil :type nil :defaults path
+ :directory (append (or (pathname-directory path)
+ (list :relative))
+ (list (file-namestring path))))))
+
+ (t
+ ;; This actually looks like a plain directory name.
+
+ (setf var path))))))
+
(export 'main)
(defun main ()
+
+ ;; Initialize the argument parser.
(set-command-line-arguments)
- (define-program
- :help "Probably ought to write this."
- :version "0.1.0"
- :usage nil
- :options (options
- (help-options :short-version #\V)
- "Crazy options"
- ))
-
- (unless (option-parse-try
- (do-options ()
- (nil (rest)
- (format t "My arguments are ~S~%" rest))))
- (die-usage))
- (exit))
+ ;; Collect information from the command line options.
+ (let ((output-reasons nil)
+ (output-path (make-pathname :directory '(:relative)))
+ (builtinsp nil)
+ (stdoutp nil)
+ (args nil))
+
+ ;; Option definitions.
+ (define-program
+ :help "Probably ought to write this."
+ :version "0.1.0"
+ :usage "SOURCES..."
+ :options (options
+ (help-options :short-version #\V)
+ "Crazy options"
+ (#\I "include" (:arg "DIR")
+ ("Search DIR for module imports.")
+ (list *module-dirs* 'string))
+ ("builtins"
+ ("Process the builtin `sod-base' module.")
+ (set builtinsp))
+ (#\d "directory" (:arg "DIR")
+ ("Write output files to DIR.")
+ (dirpath output-path))
+ (#\p "stdout"
+ ("Write output files to standard output.")
+ (set stdoutp))
+ (#\t "type" (:arg "OUT-TYPE")
+ ("Produce output of type OUT-TYPE.")
+ (list output-reasons 'keyword))))
+
+ ;; Actually parse the options.
+ (unless (and (option-parse-try
+ (do-options ()
+ (nil (rest)
+ (setf args rest))))
+ (or builtinsp args))
+ (die-usage))
+
+ ;; Prepare the builtins.
+ (make-builtin-module)
+
+ ;; Do the main parsing job.
+ (multiple-value-bind (hunoz nerror nwarn)
+ (count-and-report-errors ()
+ (with-default-error-location ((make-file-location *program-name*))
+
+ (flet ((hack-module (module)
+ ;; Process the MODULE, writing out the generated code.
+
+ ;; Work through each output type in turn.
+ (dolist (reason output-reasons)
+
+ ;; Arrange to be able to recover from errors.
+ (restart-case
+
+ ;; Collect information for constructing the output
+ ;; filenames here. In particular,
+ ;; `output-type-pathname' will sanity-check the
+ ;; output type for us, which is useful even if
+ ;; we're writing to stdout.
+ (let ((outpath (output-type-pathname reason))
+ (modpath (module-name module)))
+
+ (if stdoutp
+
+ ;; If we're writing to stdout then just do
+ ;; that.
+ (output-module module reason
+ *standard-output*)
+
+ ;; Otherwise we have to construct an output
+ ;; filename the hard way.
+ (with-open-file
+ (stream
+ (reduce #'merge-pathnames
+ (list output-path
+ outpath
+ (make-pathname
+ :directory nil
+ :defaults modpath))
+ :from-end t)
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (output-module module reason stream))))
+
+ ;; Error recovery.
+ (continue ()
+ :report (lambda (stream)
+ (format stream
+ "Skip output type `~(~A~)'"
+ reason))
+ nil)))))
+
+ ;; If we're writing the builtin module then now seems like a
+ ;; good time to do that.
+ (when builtinsp
+ (clear-the-decks)
+ (hack-module *builtin-module*))
+
+ ;; Parse and write out the remaining modules.
+ (dolist (arg args)
+ (clear-the-decks)
+ (hack-module (read-module arg))))))
+
+ ;; Report on how well everything worked.
+ (declare (ignore hunoz))
+ (when (or (plusp nerror) (plusp nwarn))
+ (format *error-output* "~A: Finished with~
+ ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
+ ~[~:; ~:*~D warning~:P~]~%"
+ *program-name* nerror nwarn))
+
+ ;; Exit with a sensible status.
+ (exit (if (plusp nerror) 2 0)))))
;;;----- That's all, folks --------------------------------------------------
(setf (slot-value method 'next-method-type)
(c-type (fun (lisp (c-type-subtype type))
("me" (* (class (sod-method-class method))))
- . (c-function-arguments type))))))
+ .
+ (c-function-arguments type))))))
(defmethod slot-unbound (class
(method delegating-direct-method)
(emf-type (c-type (fun (lisp return-type)
("sod__obj" (lisp ilayout-type))
. (sod-message-no-varargs-tail message))))
- (result (if (eq return-type (c-type void)) nil
- (temporary-var codegen return-type)))
- (emf-target (or result :void))
;; Method entry details.
(chain-tails (remove-if-not (lambda (super)
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
- (compute-effective-method-body method codegen emf-target)
- (multiple-value-bind (vars insts) (codegen-pop codegen)
- (cond ((or (= n-entries 1)
- (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
- *method-entry-inline-threshold*))
-
- ;; The effective method body is simple -- or there's only one
- ;; of them. We'll inline the method body into the entry
- ;; functions.
- (dolist (tail chain-tails)
- (setup-entry tail)
- (dolist (var vars)
- (ensure-var codegen (inst-name var)
- (inst-type var) (inst-init var)))
- (when parm-n (varargs-prologue))
- (emit-insts codegen insts)
- (when parm-n (varargs-epilogue))
- (deliver-expr codegen entry-target result)
- (finish-entry tail)))
-
- (t
-
- ;; The effective method body is complicated and we'd need more
- ;; than one copy. We'll generate an effective method function
- ;; and call it a lot.
- (codegen-build-function codegen emf-name emf-type vars
- (nconc insts (and result (list (make-return-inst result)))))
-
- (let ((call (make-call-inst emf-name
- (cons "sod__obj" (mapcar #'argument-name
- emf-arg-tail)))))
+ (let* ((result (if (eq return-type (c-type void)) nil
+ (temporary-var codegen return-type)))
+ (emf-target (or result :void)))
+ (compute-effective-method-body method codegen emf-target)
+ (multiple-value-bind (vars insts) (codegen-pop codegen)
+ (cond ((or (= n-entries 1)
+ (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
+ *method-entry-inline-threshold*))
+
+ ;; The effective method body is simple -- or there's only
+ ;; one of them. We'll inline the method body into the entry
+ ;; functions.
(dolist (tail chain-tails)
(setup-entry tail)
- (cond (parm-n
- (varargs-prologue)
- (convert-stmts codegen entry-target return-type
- (lambda (target)
- (deliver-expr codegen target call)
- (varargs-epilogue))))
- (t
- (deliver-expr codegen entry-target call)))
- (finish-entry tail))))))
+ (dolist (var vars)
+ (ensure-var codegen (inst-name var)
+ (inst-type var) (inst-init var)))
+ (when parm-n (varargs-prologue))
+ (emit-insts codegen insts)
+ (when parm-n (varargs-epilogue))
+ (deliver-expr codegen entry-target result)
+ (finish-entry tail)))
+
+ (t
+
+ ;; The effective method body is complicated and we'd need
+ ;; more than one copy. We'll generate an effective method
+ ;; function and call it a lot.
+ (codegen-build-function codegen emf-name emf-type vars
+ (nconc insts (and result
+ (list (make-return-inst result)))))
+
+ (let ((call (make-call-inst emf-name
+ (cons "sod__obj" (mapcar #'argument-name
+ emf-arg-tail)))))
+ (dolist (tail chain-tails)
+ (setup-entry tail)
+ (cond (parm-n
+ (varargs-prologue)
+ (convert-stmts codegen entry-target return-type
+ (lambda (target)
+ (deliver-expr codegen
+ target call)
+ (varargs-epilogue))))
+ (t
+ (deliver-expr codegen entry-target call)))
+ (finish-entry tail)))))))
(codegen-functions codegen))))
(let* ((message (sod-method-message direct-method))
(class (sod-method-class direct-method))
(function (sod-method-function-name direct-method))
- (arguments (cons (format nil "&sod__obj.~A.~A"
+ (arguments (cons (format nil "&sod__obj->~A.~A"
(sod-class-nickname
(sod-class-chain-head class))
(sod-class-nickname class))
(when truename
(setf (gethash truename *module-map*) *module*))
(unwind-protect
- (call-with-module-environment (lambda ()
- (module-import *builtin-module*)
- (funcall thunk)
- (finalize-module *module*)))
+ (with-module-environment ()
+ (module-import *builtin-module*)
+ (funcall thunk)
+ (finalize-module *module*))
(when (and truename (not (eq (module-state *module*) t)))
(remhash truename *module-map*)))))
+(defun call-with-module-environment (thunk &optional (module *module*))
+ "Invoke THUNK with bindings for the module variables in scope.
+
+ This is the guts of `with-module-environment', which you should probably
+ use instead."
+ (progv
+ (mapcar #'car *module-bindings-alist*)
+ (module-variables module)
+ (unwind-protect (funcall thunk)
+ (setf (module-variables module)
+ (mapcar (compose #'car #'symbol-value)
+ *module-bindings-alist*)))))
+
(defun call-with-temporary-module (thunk)
"Invoke THUNK in the context of a temporary module, returning its values.
(let ((*module* (make-instance 'module
:name "<temp>"
:state nil)))
- (call-with-module-environment
- (lambda ()
- (module-import *builtin-module*)
- (funcall thunk)))))
+ (with-module-environment ()
+ (module-import *builtin-module*)
+ (funcall thunk))))
;;;--------------------------------------------------------------------------
;;; Type definitions.
(fresh-line stream)
(format stream "~&#line ~D ~S~%"
(1+ (position-aware-stream-line stream))
- (namestring (stream-pathname stream)))))
+ (let ((path (stream-pathname stream)))
+ (if path (namestring path) "<sod-output>")))))
(t
(funcall thunk)))))
(make-instance 'position-aware-output-stream
:stream stream
:file (stream-pathname stream)))))
- (hook-output module reason sequencer)
- (invoke-sequencer-items sequencer stream)))
+ (with-module-environment (module)
+ (hook-output module reason sequencer)
+ (invoke-sequencer-items sequencer stream))))
;;;--------------------------------------------------------------------------
;;; Output implementation.
(:prologue
(format stream "~
-/* -*-c-*-
+/* -*- mode: c; indent-tabs-mode: nil -*-
*
* Header file generated by SOD for ~A
*/~2%"
(:prologue
(format stream "~
-/* -*-c-*-
+/* -*- mode: c; indent-tabs-mode: nil -*-
*
* Implementation file generated by SOD for ~A
*/~2%"
((:includes :end)
(terpri stream))))
+;;;--------------------------------------------------------------------------
+;;; Output types.
+
+(defvar *output-types* nil
+ "List of known output types.")
+
+(export 'declare-output-type)
+(defun declare-output-type (reason pathname)
+ "Record that REASON is a valid user-level output type.
+
+ The output file name will be constructed by merging the module's pathname
+ with PATHNAME."
+ (setf (get reason 'output-type) pathname))
+
+(export 'output-type-pathname)
+(defun output-type-pathname (reason)
+ "Return the PATHNAME template for the output type REASON.
+
+ Report an error if there is no such output type."
+ (or (get reason 'output-type)
+ (error "Unknown output type `~(~A~)'" reason)))
+
+(define-clear-the-decks reset-output-types
+ "Clear out the registered output types."
+ (dolist (reason *output-types*) (remprop reason 'output-type))
+ (setf *output-types* nil)
+ (declare-output-type :c (make-pathname :type "C" :case :common))
+ (declare-output-type :h (make-pathname :type "H" :case :common)))
+
;;;----- That's all, folks --------------------------------------------------
;;;--------------------------------------------------------------------------
;;; Toplevel syntax.
-(export 'module)
-
;;; Type names.
(define-pluggable-parser module typename (scanner pset)
;; constraint ::= id+
(declare (ignore pset))
(with-parser-context (token-scanner-context :scanner scanner)
- (parse (seq ("code"
- (reason :id)
- #\:
- (name :id)
- (constraints (? (seq (#\[
- (constraints (list (:min 1)
- (list (:min 1) :id)
- #\,))
- #\])
- constraints)))
- (fragment (parse-delimited-fragment scanner #\{ #\})))
- (add-to-module *module* (make-instance 'code-fragment-item
- :fragment fragment
- :constraints constraints
- :reason reason
- :name name))))))
+ (flet ((kw ()
+ (parse (seq ((kw :id)) (intern (string-upcase kw) 'keyword)))))
+ (parse (seq ("code"
+ (reason (kw))
+ #\:
+ (name (kw))
+ (constraints (? (seq (#\[
+ (constraints (list (:min 1)
+ (list (:min 1) (kw))
+ #\,))
+ #\])
+ constraints)))
+ (fragment (parse-delimited-fragment scanner #\{ #\})))
+ (add-to-module *module*
+ (make-instance 'code-fragment-item
+ :fragment fragment
+ :constraints constraints
+ :reason reason
+ :name name)))))))
;;; External files.
-(defun read-module (pathname &key (truename (truename pathname)) location)
+(export 'read-module)
+(defun read-module (pathname &key (truename nil truep) location)
"Parse the file at PATHNAME as a module, returning it.
This is the main entry point for parsing module files. You may well know
`file-location' object, though it might be anything other than `t' which
can be printed in the event of circular imports."
+ (setf pathname (merge-pathnames pathname
+ (make-pathname :type "SOD" :case :common)))
+ (unless truep (setf truename (truename pathname)))
(define-module (pathname :location location :truename truename)
(with-open-file (f-stream pathname :direction :input)
(let* ((*readtable* (copy-readtable))
;;
;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a
;; `sod-initializer' constructor.
- (parse (or (peek (seq (#\= (frag (parse-delimited-fragment
- scanner #\{ #\})))
- (cons :compound frag)))
- (seq ((frag (parse-delimited-fragment
- scanner #\= '(#\; #\,)
- :keep-end t)))
- (cons :simple frag)))))
+
+ ;; This is kind of tricky because we have to juggle both
+ ;; layers of the parsing machinery. The character scanner
+ ;; will already have consumed the lookahead token (which, if
+ ;; we're going to do anything, is `=').
+ (let ((char-scanner (token-scanner-char-scanner scanner)))
+
+ ;; First, skip the character-scanner past any whitespace.
+ ;; We don't record this consumption, which is a bit
+ ;; naughty, but nobody will actually mind.
+ (loop
+ (when (or (scanner-at-eof-p char-scanner)
+ (not (whitespace-char-p
+ (scanner-current-char char-scanner))))
+ (return))
+ (scanner-step char-scanner))
+
+ ;; Now maybe read an initializer.
+ (cond ((not (eql (token-type scanner) #\=))
+ ;; It's not an `=' after all. There's no
+ ;; initializer.
+ (values '(#\=) nil nil))
+
+ ((and (not (scanner-at-eof-p char-scanner))
+ (char= (scanner-current-char char-scanner)
+ #\{))
+ ;; There's a brace after the `=', so we should
+ ;; consume the `=' here, and read a compound
+ ;; initializer enclosed in braces.
+ (parse (seq (#\= (frag (parse-delimited-fragment
+ scanner #\{ #\})))
+ (cons :compound frag))))
+
+ (t
+ ;; No brace, so read from the `=' up to, but not
+ ;; including, the trailing `,' or `;' delimiter.
+ (parse (seq ((frag (parse-delimited-fragment
+ scanner #\= '(#\; #\,)
+ :keep-end t)))
+ (cons :simple frag)))))))
(parse-slot-item (sub-pset base-type type name)
;; slot-item ::=
;; (which might be dotted). So we parse that here and
;; dispatch based on what we find.
(parse (or (plug class-item scanner class sub-pset)
- (peek
+ ;(peek
(seq ((ds (parse-c-type scanner))
(dc (parse-maybe-dotted-declarator ds))
(nil (class-item-dispatch sub-pset
ds
(car dc)
- (cdr dc))))))
+ (cdr dc)))));)
(and "class"
(parse-initializer-item
sub-pset
(parse (seq (#\{
(nil (skip-many ()
(seq ((sub-pset (parse-property-set scanner))
- (nil (error ()
- (parse-raw-class-item sub-pset))))
+ (nil (parse-raw-class-item sub-pset)))
(check-unused-properties sub-pset))))
- #\})
+ (nil (error () #\})))
(finalize-sod-class class)
(add-to-module *module* class)))))))
`((setf (documentation ',name 'variable) ,documentation)))
(add-module-binding ',name (lambda () ,value-form))))
-(export 'call-with-module-environment)
-(defun call-with-module-environment (thunk)
- "Invoke THUNK with a new collection of bindings for the module variables."
- (progv
- (mapcar #'car *module-bindings-alist*)
- (mapcar (compose #'cdr #'funcall) *module-bindings-alist*)
- (funcall thunk)))
+(export 'with-module-environment)
+(defmacro with-module-environment ((&optional (module '*module*)) &body body)
+ "Evaluate the BODY with MODULE's variable bindings in scope."
+ `(call-with-module-environment (lambda () ,@body) ,module))
;;;--------------------------------------------------------------------------
;;; The reset switch.
(items :initarg :items :initform nil :type list :accessor module-items)
(dependencies :initarg :dependencies :initform nil
:type list :accessor module-dependencies)
+ (variables :initarg :variables :type list :accessor module-variables
+ :initform (mapcar (compose #'cdr #'funcall)
+ *module-bindings-alist*))
(state :initarg :state :initform nil :accessor module-state))
(:documentation
"A module is a container for the definitions made in a source file.
* A list of other modules that this one depends on.
+ * A list of module-variable values, in the order in which they're named
+ in `*module-bindings-alist*'.
+
Modules are usually constructed by the `read-module' function, though
there's nothing to stop fancy extensions building modules
programmatically."))
"Increments VAR by STEP (defaults to 1), but not greater than MAX (default
nil for no maximum). No errors are signalled."
(incf var step)
- (when (>= var max)
+ (when (and max (>= var max))
(setf var max)))
(export 'dec)
"Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
for no maximum). No errors are signalled."
(decf var step)
- (when (<= var min)
+ (when (and min (<= var min))
(setf var min)))
(export 'read)
;;;--------------------------------------------------------------------------
;;; Full program descriptions.
+(export '(*help* *version* *usage*))
(defvar *help* nil "Help text describing the program.")
(defvar *version* "<unreleased>" "The program's version number.")
(defvar *usage* nil "A usage summary string")
;;;--------------------------------------------------------------------------
;;; Output preparation.
+(export 'hook-output)
(defgeneric hook-output (object reason sequencer)
(:documentation
"Announces the intention to write SEQUENCER, with a particular REASON.
(:method-combination progn)
(:method progn (object reason sequencer)
- (declare (ignore object reason sequencer))))
+ (declare (ignore object reason sequencer))))
;;;--------------------------------------------------------------------------
;;; Useful syntax.
file-location-filename file-location-line file-location-column))
(defstruct (file-location
(:constructor make-file-location
- (%filename line column
+ (%filename &optional line column
&aux (filename
(etypecase %filename
((or string null) %filename)
'simple-warning-with-location
floc datum arguments)))
+(defun my-cerror (continue-string datum &rest arguments)
+ "Like standard `cerror', but robust against sneaky changes of conditions.
+
+ It seems that `cerror' (well, at least the version in SBCL) is careful
+ to limit its restart to the specific condition it signalled. But that's
+ annoying, because `with-default-error-location' substitutes different
+ conditions carrying the error-location information."
+ (restart-case (apply #'error datum arguments)
+ (continue ()
+ :report (lambda (stream)
+ (apply #'format stream continue-string datum arguments))
+ nil)))
+
(export 'cerror-with-location)
(defun cerror-with-location (floc continue-string datum &rest arguments)
"Report a continuable error with attached location information."
- (cerror continue-string
- (apply #'make-condition-with-location
- 'simple-error-with-location
- floc datum arguments)))
+ (my-cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
(export 'cerror*)
(defun cerror* (datum &rest arguments)
- (apply #'cerror "Continue" datum arguments))
+ (apply #'my-cerror "Continue" datum arguments))
(export 'cerror*-with-location)
(defun cerror*-with-location (floc datum &rest arguments)
(defun count-and-report-errors* (thunk)
"Invoke THUNK in a dynamic environment which traps and reports errors.
- See the `count-and-report-errors' macro for more detais."
+ See the `count-and-report-errors' macro for more details."
(let ((errors 0)
(warnings 0))
- (handler-bind
- ((error (lambda (error)
- (let ((fatal (not (find-restart 'continue error))))
- (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
- (file-location error)
- fatal
- error)
- (incf errors)
- (if fatal
- (return-from count-and-report-errors*
- (values nil errors warnings))
- (invoke-restart 'continue)))))
- (warning (lambda (warning)
- (format *error-output* "~&~A: Warning: ~A~%"
- (file-location warning)
- warning)
- (incf warnings)
- (invoke-restart 'muffle-warning))))
- (values (funcall thunk)
- errors
- warnings))))
+ (restart-case
+ (let ((our-continue-restart (find-restart 'continue)))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (eq (find-restart 'continue error)
+ our-continue-restart)))
+ (format *error-output*
+ "~&~A: ~:[~;Fatal error: ~]~A~%"
+ (file-location error)
+ fatal
+ error)
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (invoke-restart 'continue)))))
+ (warning (lambda (warning)
+ (format *error-output* "~&~A: Warning: ~A~%"
+ (file-location warning)
+ warning)
+ (incf warnings)
+ (invoke-restart 'muffle-warning))))
+ (values (funcall thunk)
+ errors
+ warnings)))
+ (continue ()
+ :report (lambda (stream) (write-string "Exit to top-level" stream))
+ (values nil errors warnings)))))
(export 'count-and-report-errors)
(defmacro count-and-report-errors (() &body body)
We remember the buffer-chain link, so that we can retrace our steps up to
the present. We also need the index at which we continue reading
characters; and the line and column numbers to resume from."
+ (scanner nil :type charbuf-scanner :read-only t)
(link nil :type charbuf-chain-link :read-only t)
(index 0 :type charbuf-index :read-only t)
(line 0 :type fixnum :read-only t)
(column 0 :type fixnum :read-only t))
+(defmethod file-location ((place charbuf-scanner-place))
+ (make-file-location (scanner-filename
+ (charbuf-scanner-place-scanner place))
+ (charbuf-scanner-place-line place)
+ (charbuf-scanner-place-column place)))
+
;;;--------------------------------------------------------------------------
;;; Main class.
(incf captures)
(unless tail
(setf tail (make-charbuf-chain-link :buf buf :size size)))
- (make-charbuf-scanner-place :link tail :index index
+ (make-charbuf-scanner-place :scanner scanner :link tail :index index
:line line :column column)))
(defmethod scanner-restore-place ((scanner charbuf-scanner) place)
(let* ((slices nil)
(place-b (or place-b
(with-slots (index tail) scanner
- (make-charbuf-scanner-place :link tail
+ (make-charbuf-scanner-place :scanner scanner
+ :link tail
:index index))))
(last-link (charbuf-scanner-place-link place-b)))
(flet ((bad ()
(defmethod file-location ((scanner character-scanner))
(scanner-file-location scanner))
+(defmethod file-location ((scanner token-scanner))
+ (scanner-file-location scanner))
+
;;;--------------------------------------------------------------------------
;;; Streams on character scanners.
The details of this structure are not a defined part of the token scanner
protocol."
+ (scanner nil :type token-scanner :read-only t)
(next nil :type (or token-scanner-place null))
(type nil :read-only t)
(value nil :read-only t)
scanner protocol, which explains the model.
Subclasses must provide the detailed scanning behaviour -- most notably
- the `scanner-token' generic function. This function should also update
- the `line' and `column' slots to track the position in the underlying
- source, if appropriate, and also implement a method on `file-location' to
- return the location. This class will handle the remaining details, such
- as dealing correctly with rewinding."))
+ the `scanner-token' generic function -- and also implement a method on
+ `file-location' to return the location. The `scanner-token' method should
+ also update the `line' and `column' slots to track the position in the
+ underlying source, if appropriate. This class will handle the remaining
+ details, such as dealing correctly with rewinding."))
(export 'token-scanner-context)
(defclass token-scanner-context (scanner-context token-parser-context)
;;;--------------------------------------------------------------------------
;;; Token scanner implementation.
+(defmethod file-location ((place token-scanner-place))
+ (make-file-location (scanner-filename (token-scanner-place-scanner place))
+ (token-scanner-place-line place)
+ (token-scanner-place-column place)))
+
(defmethod shared-initialize :after
((scanner token-scanner) slot-names &key)
(declare (ignore slot-names))
(setf type ty
value val)
(if (plusp captures)
- (let ((next (make-token-scanner-place
- :type ty :value val
- :line line :column column)))
+ (let ((next (make-token-scanner-place :scanner scanner
+ :type ty :value val
+ :line line
+ :column column)))
(setf (token-scanner-place-next tail) next
tail next))
(setf tail nil)))))))
(with-slots (type value captures tail line column) scanner
(incf captures)
(or tail
- (setf tail (make-token-scanner-place
- :type type :value value :line line :column column)))))
+ (setf tail (make-token-scanner-place :scanner scanner
+ :type type :value value
+ :line line :column column)))))
(defmethod scanner-restore-place ((scanner token-scanner) place)
(with-slots (type value tail line column) scanner
(:file "pset-parse" :depends-on ("pset-proto" "lexer-proto"))
;; Code generation protocol.
- (:file "codegen-proto" :depends-on ("package"))
+ (:file "codegen-proto" :depends-on ("module-proto"))
(:file "codegen-impl" :depends-on ("codegen-proto"))
;; Modules.
(:file "method-impl" :depends-on ("method-proto"))
;; Class output.
- (:file "class-output" :depends-on ("output-proto" "classes"))
+ (:file "class-output" :depends-on
+ ("classes" "class-layout-proto" "class-layout-impl"
+ "method-proto" "method-impl" "output-proto"))
;; User interface.
(:file "frontend" :depends-on
except where overridden by INITARGS."
(apply #'copy-instance-using-class (class-of object) object initargs))
+(export '(generic-function-methods method-specializers
+ eql-specializer eql-specializer-object))
+
;;;--------------------------------------------------------------------------
;;; List utilities.
~mdw / sod / commitdiff