(defun read-module (pathname &key (truename (truename pathname)) location)
"Reads a module.
- The module is returned if all went well; NIL is returned if an error
+ The module is returned if all went well; nil is returned if an error
occurred.
The PATHNAME argument is the file to read. TRUENAME should be the file's
truename, if known: often, the file will have been searched for using
- PROBE-FILE or similar, which drops the truename into your lap."
+ `probe-file' or similar, which drops the truename into your lap."
;; Deal with a module which is already in the map. If its state is a
;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
;;;--------------------------------------------------------------------------
;;; File searching.
-(defparameter *module-dirs* nil
- "A list of directories (as pathname designators) to search for files.
-
- Both SOD module files and Lisp extension files are searched for in this
- list. The search works by merging the requested pathname with each
- element of this list in turn. The list is prefixed by the pathname of the
- requesting file, so that it can refer to other files relative to wherever
- it was found.
-
- See FIND-FILE for the grubby details.")
-
-(defun find-file (lexer name what thunk)
- "Find a file called NAME on the module search path, and call THUNK on it.
-
- The file is searched for relative to the LEXER's current file, and also in
- the directories mentioned in the *MODULE-DIRS* list. If the file is
- found, then THUNK is invoked with two arguments: the name we used to find
- it (which might be relative to the starting directory) and the truename
- found by PROBE-FILE.
-
- If the file wasn't found, or there was some kind of error, then an error
- is signalled; WHAT should be a noun phrase describing the kind of thing we
- were looking for, suitable for inclusion in the error message.
-
- While FIND-FILE establishes condition handlers for its own purposes, THUNK
- is not invoked with any additional handlers defined."
-
- (handler-case
- (dolist (dir (cons (stream-pathname (lexer-stream lexer))
- *module-dirs*)
- (values nil nil))
- (let* ((path (merge-pathnames name dir))
- (probe (probe-file path)))
- (when probe
- (return (values path probe)))))
- (file-error (error)
- (error "Error searching for ~A ~S: ~A" what (namestring name) error))
- (:no-error (path probe)
- (cond ((null path)
- (error "Failed to find ~A ~S" what (namestring name)))
- (t
- (funcall thunk path probe))))))
(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
"module-decl ::= `import' string `;'"
--- /dev/null
+/* another example module */
+
+demo "bar, before import";
+import "foo";
+demo "bar, after import";
(defun find-instance-slot-by-name (class super-nick slot-name)
(let ((super (find-superclass-by-nick class super-nick)))
- (find-thing-by-name "slot" super (sod-class-slots super)
+ (find-thing-by-name "instance slot" super (sod-class-slots super)
slot-name #'sod-slot-name)))
(defun find-class-slot-by-name (class super-nick slot-name)
(let* ((meta (sod-class-metaclass class))
(super (find-superclass-by-nick meta super-nick)))
- (find-thing-by-name "slot" super (sod-class-slots super)
+ (find-thing-by-name "class slot" super (sod-class-slots super)
slot-name #'sod-slot-name)))
(defun find-message-by-name (class super-nick message-name)
;;
;; Note! This function gets called from `check-sod-class' before the
;; class's chains have been computed. Therefore we iterate over the direct
- ;; superclass's chains rather than the class's own. This misses a chain
+ ;; superclasses' chains rather than the class's own. This misses a chain
;; only in the case where the class is its own chain head. There are two
;; subcases: if there are no direct superclasses at all, then the class is
;; its own root; otherwise, it clearly can't be the root and the omission
(class :initarg :class :type sod-class :reader sod-message-class)
(type :initarg :type :type c-function-type :reader sod-message-type))
(:documentation
- "Messages the means for stimulating an object to behave.
+ "Messages are the means for stimulating an object to behave.
SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages'
will, in general, differ from the type of the message for several
reasons.
- -- Firstly, the method type must include names for all of the
- method's parameters. The message definition can omit the
- parameter names (in the same way as a function declaration can).
- Formally, the message definition can contain abstract
- declarators, whereas method definitions must not.
+ -- The method type must include names for all of the method's
+ parameters. The message definition can omit the parameter
+ names (in the same way as a function declaration can). Formally,
+ the message definition can contain abstract declarators, whereas
+ method definitions must not.
-- Method combinations may require different parameter or return
- types. For example, `before' and `after' methods don't
- contribute to the message's return value, so they must be defined
- as returning `void'.
+ types. For example, `before' and `after' methods don't
+ contribute to the message's return value, so they must be defined
+ as returning `void'.
-- Method combinations may permit methods whose parameter and/or
- return types don't exactly match the corresponding types of the
- message. For example, one might have methods with covariant
- return types and contravariant parameter types. (This sounds
- nice, but it doesn't actually seem like such a clever idea when
- you consider that the co-/contravariance must hold among all the
- applicable methods ordered according to the class precedence
- list. As a result, a user might have to work hard to build
- subclasses whose CPLs match the restrictions implied by the
- method types.)
+ return types don't exactly match the corresponding types of the
+ message. For example, one might have methods with covariant
+ return types and contravariant parameter types. (This sounds
+ nice, but it doesn't actually seem like such a clever idea when
+ you consider that the co-/contravariance must hold among all the
+ applicable methods ordered according to the class precedence
+ list. As a result, a user might have to work hard to build
+ subclasses whose CPLs match the restrictions implied by the
+ method types.)
Method objects are fairly passive in the SOD translator. However,
subclasses of `sod-message' may (and probably will) construct instances of
--- /dev/null
+/* foo */
+
+code header : include {
+#include "foo.h"
+}
+lisp (format t "hello, world!~%");
+demo "found foo ok";
--- /dev/null
+(in-package #:sod)
+
+(defun make-lexer (string)
+ (make-instance 'sod-token-scanner
+ :char-scanner (make-string-scanner string)
+ :filename "<string>"))
;;
;; The solution is to make the `*module-type-map*' be the master. Each
;; class-type object has a tag -- a gensym, so that `equal' will think
- ;; they're different, and we use the tag as part of the input to
+ ;; they're different -- and we use the tag as part of the input to
;; `intern-c-type'.
;;
;; So the first thing to do is to find the tag for the basic type, without
(assert (gethash k map))))
*c-type-intern-map*)))
+(defmethod qualify-c-type ((type qualifiable-c-type) qualifiers)
+ (let ((initargs (instance-initargs type)))
+ (remf initargs :qualifiers)
+ (apply (if (gethash type *c-type-intern-map*)
+ #'intern-c-type #'make-instance)
+ (class-of type)
+ :qualifiers (canonify-qualifiers
+ (append qualifiers (c-type-qualifiers type)))
+ initargs)))
+
;;;--------------------------------------------------------------------------
;;; Simple C types.
(keyword (intern (symbol-name kind) :keyword))
(constructor (symbolicate 'make- kind '-type)))
`(progn
- (export '(,type ,constructor))
+ (export '(,type ,kind ,constructor))
(defclass ,type (tagged-c-type) ()
(:documentation ,(format nil "C ~a types." what)))
(defmethod c-tagged-type-kind ((type ,type))
(defun clos-tiebreaker (candidates so-far)
"The CLOS linearization tiebreaker function.
- Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
- has a direct subclass furthest to the right in the list SO-FAR.
+ Intended for use with `merge-lists'. Returns the member of CANDIDATES
+ which has a direct subclass furthest to the right in the list SO-FAR.
This must disambiguate. The SO-FAR list cannot be empty, since the class
under construction precedes all of the others. If two classes share a
(defun c3-tiebreaker (candidates cpls)
"The C3 linearization tiebreaker function.
- Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
- appears in the earliest element of CPLS, which should be the list of the
- class precedence lists of the direct superclasses of the class in
+ Intended for use with `merge-lists'. Returns the member of CANDIDATES
+ which appears in the earliest element of CPLS, which should be the list of
+ the class precedence lists of the direct superclasses of the class in
question, in the order specified in the class declaration.
The only class in the class precedence list which does not appear in one
"Compute the class precedence list of CLASS using CLOS linearization rules.
We merge the direct-superclass lists of all of CLASS's superclasses,
- disambiguating using CLOS-TIEBREAKER.
+ disambiguating using `clos-tiebreaker'.
The CLOS linearization preserves local class ordering, but is not
monotonic, and does not respect the extended precedence graph. CLOS
We merge the direct-superclass list of CLASS with the full class
precedence lists of its direct superclasses, disambiguating using
- CLOS-TIEBREAKER. (Inductively, these lists will be consistent with the
+ `clos-tiebreaker'. (Inductively, these lists will be consistent with the
CPLs of indirect superclasses, since those CPLs' orderings are reflected
in the CPLs of the direct superclasses.)
We merge the direct-superclass list of CLASS with the full class
precedence lists of its direct superclasses, disambiguating using
- C3-TIEBREAKER.
+ `c3-tiebreaker'.
The C3 linearization preserves local class ordering, is monotonic, and
respects the extended precedence graph. It is the linearization used in
(defmethod finalize-sod-class ((class sod-class))
- ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
+ ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
;; clone of the CPL and chain establishment code. If the interface changes
- ;; then BOOTSTRAP-CLASSES will need to be changed too.
+ ;; then `bootstrap-classes' will need to be changed too.
(with-default-error-location (class)
(ecase (sod-class-state class)
conventionally named `sod__ap_master', which it is expected to pass on to
its `next_method' function if necessary.)
- The function type protocol is implemented on DELEGATING-DIRECT-METHOD
+ The function type protocol is implemented on `delegating-direct-method'
using slot reader methods. The actual values are computed on demand in
- methods defined on SLOT-UNBOUND."))
+ methods defined on `slot-unbound'."))
(defmethod slot-unbound (class
(method delegating-direct-method)
("next_method" (* (lisp (commentify-function-type
(sod-method-next-method-type
method)))))
- . (if (varargs-message-p message)
- (cons (make-argument *sod-master-ap*
- (c-type va-list))
- method-args)
- method-args))))))
+ .
+ (if (varargs-message-p message)
+ (cons (make-argument *sod-master-ap*
+ (c-type va-list))
+ method-args)
+ method-args))))))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
;; The first thing we need to do is find all of the related objects. This
;; is a bit verbose but fairly straightforward.
;;
- ;; Next, we generate the effective method body -- using COMPUTE-EFFECTIVE-
- ;; METHOD-BODY of all things. This gives us the declarations and body for
+ ;; Next, we generate the effective method body -- using `compute-effective-
+ ;; method-body' of all things. This gives us the declarations and body for
;; an effective method function, but we don't have an actual function yet.
;;
;; Now we look at the chains which are actually going to need a method
(name thunk &key (truename (probe-file name)) location)
"Construct a new module.
- This is the functionality underlying `define-module'."
-
+ This is the functionality underlying `define-module': see that macro for
+ full information."
+
+ ;; Check for an import cycle.
+ (when truename
+ (let ((existing (gethash truename *module-map*)))
+ (cond ((null existing))
+ ((eq (module-state existing) t)
+ (return-from build-module existing))
+ (t
+ (error "Module ~A already being imported at ~A"
+ name (module-state existing))))))
+
+ ;; Construct the new module.
(let ((*module* (make-instance 'module
:name (pathname name)
:state (file-location location))))
(cons 'list constraint))
constraints))))))
+;;;--------------------------------------------------------------------------
+;;; File searching.
+
+(export '*module-dirs*)
+(defparameter *module-dirs* nil
+ "A list of directories (as pathname designators) to search for files.
+
+ Both SOD module files and Lisp extension files are searched for in this
+ list. The search works by merging the requested pathname with each
+ element of this list in turn. The list is prefixed by the pathname of the
+ requesting file, so that it can refer to other files relative to wherever
+ it was found.
+
+ See `find-file' for the grubby details.")
+
+(export 'find-file)
+(defun find-file (scanner name what thunk)
+ "Find a file called NAME on the module search path, and call THUNK on it.
+
+ The file is searched for relative to the SCANNER's current file, and also
+ in the directories mentioned in the `*module-dirs*' list. If the file is
+ found, then THUNK is invoked with two arguments: the name we used to find
+ it (which might be relative to the starting directory) and the truename
+ found by `probe-file'.
+
+ If the file wasn't found, or there was some kind of error, then an error
+ is signalled; WHAT should be a noun phrase describing the kind of thing we
+ were looking for, suitable for inclusion in the error message.
+
+ While `find-file' establishes condition handlers for its own purposes,
+ THUNK is not invoked with any additional handlers defined."
+
+ (handler-case
+ (dolist (dir (cons (pathname (scanner-filename scanner)) *module-dirs*)
+ (values nil nil))
+ (let* ((path (merge-pathnames name dir))
+ (probe (probe-file path)))
+ (when probe
+ (return (values path probe)))))
+ (file-error (error)
+ (error "Error searching for ~A ~S: ~A" what (namestring name) error))
+ (:no-error (path probe)
+ (cond ((null path)
+ (error "Failed to find ~A ~S" what (namestring name)))
+ (t
+ (funcall thunk path probe))))))
+
;;;----- That's all, folks --------------------------------------------------
;;;--------------------------------------------------------------------------
;;; Declaration specifiers.
+;;;
+;;; This stuff is distressingly complicated.
+;;;
+;;; Parsing a (single) declaration specifier is quite easy, and a declaration
+;;; is just a sequence of these things. Except that there are a stack of
+;;; rules about which ones are allowed to go together, and the language
+;;; doesn't require them to appear in any particular order.
+;;;
+;;; A collection of declaration specifiers is carried about in a purpose-made
+;;; object with a number of handy operations defined on it, and then I build
+;;; some parsers in terms of them. The basic strategy is to parse
+;;; declaration specifiers while they're valid, and keep track of what we've
+;;; read. When I've reached the end, we'll convert what we've got into a
+;;; `canonical form', and then convert that into a C type object of the
+;;; appropriate kind. The whole business is rather more complicated than it
+;;; really ought to be.
+
+;; Firstly, a table of interesting things about the various declaration
+;; specifiers that I might encounter. I categorize declaration specifiers
+;; into four kinds.
+;;
+;; * `Type specifiers' describe the actual type, whether that's integer,
+;; character, floating point, or some tagged or user-named type.
+;;
+;; * `Size specifiers' distinguish different sizes of the same basic type.
+;; This is how we tell the difference between `int' and `long'.
+;;
+;; * `Sign specifiers' distinguish different signednesses. This is how we
+;; tell the difference between `int' and `unsigned'.
+;;
+;; * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
+;;
+;; These groupings are for my benefit here, in determining whether a
+;; particular declaration specifier is valid in the current context. I don't
+;; accept `function specifiers' (of which the only current example is
+;; `inline') since it's meaningless to me.
(defclass declspec ()
+ ;; This could have been done with DEFSTRUCT just as well, but a DEFCLASS
+ ;; can be tweaked interactively, which is a win at the moment.
((label :type keyword :initarg :label :reader ds-label)
(name :type string :initarg :name :reader ds-name)
- (kind :type (member type sign size qualifier tagged)
- :initarg :kind :reader ds-kind)))
+ (kind :type (member type sign size qualifier)
+ :initarg :kind :reader ds-kind)
+ (taggedp :type boolean :initarg :taggedp
+ :initform nil :reader ds-taggedp))
+ (:documentation
+ "Represents the important components of a declaration specifier.
+
+ The only interesting instances of this class are in the table
+ `*declspec-map*'."))
(defmethod shared-initialize :after ((ds declspec) slot-names &key)
+ "If no name is provided then derive one from the label.
+
+ Most declaration specifiers have simple names for which this works well."
(default-slot (ds 'name slot-names)
(string-downcase (ds-label ds))))
-(defclass declspecs ()
- ((type :initform nil :initarg :type :reader ds-type)
- (sign :initform nil :initarg :sign :reader ds-sign)
- (size :initform nil :initarg :size :reader ds-size)
- (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers)))
-
(defparameter *declspec-map*
(let ((map (make-hash-table :test #'equal)))
(dolist (item '((type :void :char :int :float :double)
- (size :short :long (:long-long "long long"))
+ ((type :taggedp t) :enum :struct :union)
+ (size :short :long (:long-long :name "long long"))
(sign :signed :unsigned)
- (qualifier :const :restrict :volatile)
- (tagged :enum :struct :union)))
- (let ((kind (car item)))
+ (qualifier :const :restrict :volatile)))
+ (destructuring-bind (kind &key (taggedp nil))
+ (let ((spec (car item)))
+ (if (consp spec) spec (list spec)))
(dolist (spec (cdr item))
- (multiple-value-bind (label name)
- (if (consp spec)
- (values (car spec) (cadr spec))
- (values spec (string-downcase spec)))
+ (destructuring-bind (label
+ &key
+ (name (string-downcase label))
+ (taggedp taggedp))
+ (if (consp spec) spec (list spec))
(let ((ds (make-instance 'declspec
- :label label :name name :kind kind)))
+ :label label
+ :name name
+ :kind kind
+ :taggedp taggedp)))
(setf (gethash name map) ds
(gethash label map) ds))))))
- map))
+ map)
+ "Maps symbolic labels and textual names to DECLSPEC instances.")
+
+;; A collection of declaration specifiers, and how to merge them together.
+
+(defclass declspecs ()
+ ;; Despite the fact that it looks pretty trivial, this can't be done with
+ ;; DEFCLASS for the simple reason that we add more methods to the accessor
+ ;; functions later.
+ ((type :initform nil :initarg :type :reader ds-type)
+ (sign :initform nil :initarg :sign :reader ds-sign)
+ (size :initform nil :initarg :size :reader ds-size)
+ (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
+ (:documentation
+ "Represents a collection of declaration specifiers.
+
+ This is used during type parsing to represent the type under
+ construction. Instances are immutable: we build new ones rather than
+ modifying existing ones. This leads to a certain amount of churn, but
+ we'll just have to live with that.
+
+ (Why are instances immutable? Because it's much easier to merge a new
+ specifier into an existing collection, and then check that the resulting
+ thing is valid rather than having to deal with all of the possible
+ special cases of what the new thing might be. And if the merged
+ collection isn't good, I must roll back to the previous version. So I
+ don't get to take advantage of a mutable structure.)"))
(defmethod ds-label ((ty c-type)) :c-type)
(defmethod ds-name ((ty c-type)) (princ-to-string ty))
and SIZES is either a list of acceptable specifiers of the appropriate
kind, or T, which matches any specifier.")
-(defun scan-declspec (scanner)
- "Scan a DECLSPEC from SCANNER.
-
- Value on success is either a DECLSPEC object or a C-TYPE object."
-
- ;; Turns out to be easier to do this by hand.
- (let ((ds (and (eq (token-type scanner) :id)
- (let ((kw (token-value scanner)))
- (or (gethash kw *declspec-map*)
- (gethash kw *module-type-map*))))))
- (cond ((not ds)
- (values (list :declspec) nil nil))
- ((eq (ds-kind ds) :tagged)
- (scanner-step scanner)
- (if (eq (token-type scanner) :id)
- (let ((ty (make-c-tagged-type (ds-label ds)
- (token-value scanner))))
- (scanner-step scanner)
- (values ty t t))
- (values :tag nil t)))
- (t
- (scanner-step scanner)
- (values ds t t)))))
-
(defun good-declspecs-p (specs)
"Are SPECS a good collection of declaration specifiers?"
(let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
Returns new DECLSPECS if they're OK, or `nil' if not. The old SPECS are
not modified."
+
(let* ((kind (ds-kind ds))
(old (slot-value specs kind)))
(multiple-value-bind (ok new)
(and (good-declspecs-p copy) copy))
nil))))
-(defun scan-and-merge-declspec (scanner specs)
- (with-parser-context (token-scanner-context :scanner scanner)
- (if-parse (:consumedp consumedp) (scan-declspec scanner)
- (aif (combine-declspec specs it)
- (values it t consumedp)
- (values (list :declspec) nil consumedp)))))
-
(defun declspecs-type (specs)
+ "Convert `declspecs' SPECS into a standalone C type object."
(let ((type (ds-type specs))
(size (ds-size specs))
- (sign (ds-sign specs)))
- (cond ((or type size sign)
- (when (and (eq (ds-label sign) :signed)
+ (sign (ds-sign specs))
+ (quals (mapcar #'ds-label (ds-qualifiers specs))))
+ (cond ((typep type 'c-type)
+ (qualify-c-type type quals))
+ ((or type size sign)
+ (when (and sign (eq (ds-label sign) :signed)
(eq (ds-label type) :int))
(setf sign nil))
(cond ((and (or (null type) (eq (ds-label type) :int))
(mapcar #'ds-label
(remove nil
(list sign size type))))
- (mapcar #'ds-label (ds-qualifiers specs))))
+ quals))
(t
nil))))
-(defun parse-c-type (scanner)
- (with-parser-context (token-scanner-context :scanner scanner)
- (if-parse (:result specs :consumedp cp)
- (many (specs (make-instance 'declspecs) it :min 1)
- (scan-and-merge-declspec scanner specs))
- (let ((type (declspecs-type specs)))
- (if type (values type t cp)
- (values (list :declspec) nil cp))))))
+;; Parsing declaration specifiers.
+(define-indicator :declspec "<declaration-specifier>")
+(defun scan-declspec
+ (scanner &key (predicate (constantly t)) (indicator :declspec))
+ "Scan a DECLSPEC from SCANNER.
+ If PREDICATE is provided then only succeed if (funcall PREDICATE DECLSPEC)
+ is true, where DECLSPEC is the raw declaration specifier or C-type object,
+ so we won't have fetched the tag for a tagged type yet. If the PREDICATE
+ returns false then the scan fails without consuming input.
+ If we couldn't find an acceptable declaration specifier then issue
+ INDICATOR as the failure indicator. Value on success is either a
+ `declspec' object or a `c-type' object."
+ ;; Turns out to be easier to do this by hand.
+ (let ((ds (and (eq (token-type scanner) :id)
+ (let ((kw (token-value scanner)))
+ (or (gethash kw *module-type-map*)
+ (gethash kw *declspec-map*))))))
+ (cond ((or (not ds) (and predicate (not (funcall predicate ds))))
+ (values (list indicator) nil nil))
+ ((ds-taggedp ds)
+ (scanner-step scanner)
+ (if (eq (token-type scanner) :id)
+ (let ((ty (make-c-tagged-type (ds-label ds)
+ (token-value scanner))))
+ (scanner-step scanner)
+ (values ty t t))
+ (values :tag nil t)))
+ (t
+ (scanner-step scanner)
+ (values ds t t)))))
+(defun scan-and-merge-declspec (scanner specs)
+ "Scan a declaration specifier and merge it with SPECS.
+
+ This is a parser function. If it succeeds, it returns the merged
+ `declspecs' object. It can fail either if no valid declaration specifier
+ is found or it cannot merge the declaration specifier with the existing
+ SPECS."
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (if-parse (:consumedp consumedp) (scan-declspec scanner)
+ (aif (combine-declspec specs it)
+ (values it t consumedp)
+ (values (list :declspec) nil consumedp)))))
+
+(defun parse-c-type (scanner)
+ "Parse a C type from declaration specifiers.
+ This is a parser function. If it succeeds then the result is a `c-type'
+ object representing the type it found. Note that this function won't try
+ to parse a C declarator."
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (if-parse (:result specs :consumedp cp)
+ (many (specs (make-instance 'declspecs) it :min 1)
+ (peek (scan-and-merge-declspec scanner specs)))
+ (let ((type (declspecs-type specs)))
+ (if type (values type t cp)
+ (values (list :declspec) nil cp))))))
+;;;--------------------------------------------------------------------------
+;;; Parsing declarators.
+;;;
+;;; The syntax of declaration specifiers was horrific. Declarators are a
+;;; very simple expression syntax, but this time the semantics are awful. In
+;;; particular, they're inside-out. If <> denotes mumble of foo, then op <>
+;;; is something like mumble of op of foo. Unfortunately, the expression
+;;; parser engine wants to apply op of mumble of foo, so I'll have to do some
+;;; work to fix the impedance mismatch.
+;;;
+;;; The currency we'll use is a pair (FUNC . NAME), with the semantics that
+;;; (funcall FUNC TYPE) returns the derived type. The result of
+;;; `parse-declarator' will be of this form.
+(defun parse-declarator (scanner base-type &key abstractp)
+ (with-parser-context (token-scanner-context :scanner scanner)
- ;; This is rather complicated, but extracting all the guts into a structure
- ;; and passing it around makes matters worse rather than better.
- ;;
- ;; We categorize declaration specifiers into four kinds.
- ;;
- ;; * `Type specifiers' describe the actual type, whether that's integer,
- ;; character, floating point, or some tagged or user-named type.
- ;;
- ;; * `Size specifiers' distinguish different sizes of the same basic
- ;; type. This is how we tell the difference between `int' and `long'.
- ;;
- ;; * `Sign specifiers' distinguish different signednesses. This is how
- ;; we tell the difference between `int' and `unsigned'.
- ;;
- ;; * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
- ;;
- ;; These groupings are for our benefit here, in determining whether a
- ;; particular declaration specifier is valid in the current context. We
- ;; don't accept `function specifiers' (of which the only current example is
- ;; `inline') since it's meaningless to us.
- ;;
- ;; Our basic strategy is to parse declaration specifiers while they're
- ;; valid, and keep track of what we've read. When we've reached the end,
- ;; we'll convert what we've got into a `canonical form', and then convert
- ;; that into a C type object of the appropriate kind.
-
- (let ((specs (make-instance 'declspecs)))
-
-
- (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
- (labels ((goodp (ty sg sz)
- "Are (TY SG SZ) a good set of declaration specifiers?"
- (some (lambda (it)
- (every (lambda (spec pat)
- (or (eq pat t) (eq spec nil)
- (member spec pat)))
- decls it))
- *good-declspecs*))
-
- (scan-declspec ()
- "Scan a declaration specifier."
- (flet ((win (value &optional (consumedp t))
- (when consumedp (scanner-step scanner))
- (return-from scan-declspec
- (values value t consumedp)))
- (lose (wanted &optional (consumedp nil))
- (values wanted nil consumedp)))
- (unless (eq (token-type scanner) :id) (lose :declspec))
- (let* ((id (token-value scanner))
- (ds (or (gethash id *declspec-map*)
- (gethash id *module-type-map*))))
- (unless ds (lose :declspec))
- (let ((label (ds-label ds)))
- (ecase (ds-kind ds)
- (:qualifier
- (push (ds-label ds) quals)
- (win ds))
- (:size
- (cond ((and (not size) (goodp type label sign))
- (setf size label)
- (win ds))
- (t
- (lose :declspec))))
- (:sign
- (cond ((and (not sign) (goodp type size label))
- (setf sign label)
- (win ds))
- (t
- (lose :declspec))))
- (:type
- (when (and (eq type :long) (eq label :long))
- (setf label :long-long))
- (cond ((and (or (not type) (eq type :long))
- (goodp label size sign))
- (setf type label)
- (win ds))
- (t
- (lose :declspec))))
- (:tagged
- (unless (and (not type) (goodp label size sign))
- (lose :declspec))
- (scanner-step scan)
- (unless (eq (token-type scanner) :id)
- (lose :tagged t))
- (setf type
- (make-c-tagged-type label
- (token-value scanner)))
- (win type))))))))
-
- (with-parser-context (token-scanner-context :scanner scanner)
- (many (nil nil nil :min 1)
- (scan-declspec))
-
-
-
-
- (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
- (labels ((check (ty sz sg)
- (case ty
- ((nil :int) t)
- (:char (null sz))
- (:double (and (null sg) (or (null sz) (eq sz :long))))
- (t (and (null sg) (null sz)))))
- (set-type (ty)
- (when ))
- (set-size (sz)
- (when (and (eq sz :long) (eq size :long))
- (setf sz :long-long))
- (when (and (or (null size) (eq sz :long-long))
- (check type sz sign))
- (setf size sz)))
- (set-sign (sg)
- (when (and (null sign) (check type size sg))
- (setf sign sg)))
- (parse-declspec ()
- (multiple-value-bind (kind value)
- (categorize-declspec scanner)
- (if (ecase kind
- (:qualifier (push value quals))
- (:type (and (null type) (check value size sign)
- (setf type value)))
- (:size (let ((sz (if (and (eq size :long)
- (eq value :long))
- :long-long value)))
- (and (or (null size) (eq sz :long-long))
- (check type value sign)
- (setf size value))))
- (:sign (and (null sign) (check type size value)
- (setf sign value)))
-
+ (labels ((qualifiers ()
+ ;; QUALIFIER*
+
+ (parse
+ (seq ((quals (list ()
+ (scan-declspec
+ scanner
+ :indicator :qualifier
+ :predicate (lambda (ds)
+ (and (typep ds 'declspec)
+ (eq (ds-kind ds)
+ 'qualifier)))))))
+ (mapcar #'ds-label quals))))
+
+ (star ()
+ ;; Prefix: `*' QUALIFIERS
+
+ (parse (seq (#\* (quals (qualifiers)))
+ (preop "*" (state 9)
+ (cons (lambda (type)
+ (funcall (car state)
+ (make-pointer-type type quals)))
+ (cdr state))))))
+
+ (prefix-lparen ()
+ ;; Prefix: `('
+ ;;
+ ;; Opening parentheses are treated as prefix operators by the
+ ;; expression parsing engine. There's an annoying ambiguity
+ ;; in the syntax if abstract declarators are permitted: a `('
+ ;; might be either the start of a nested subdeclarator or the
+ ;; start of a postfix function argument list. The two are
+ ;; disambiguated by stating that if the token following the
+ ;; `(' is a `)' or a declaration specifier, then we have a
+ ;; postfix argument list.
+
+ (parse
+ (peek (seq (#\(
+ (nil (if (and abstractp
+ (eq (token-type scanner) :id)
+ (let ((id (token-value scanner)))
+ (or (gethash id
+ *module-type-map*)
+ (gethash id
+ *declspec-map*))))
+ (values nil nil nil)
+ (values t t nil))))
+ (lparen #\))))))
+
+ (centre ()
+ ;; ID | empty
+ ;;
+ ;; The centre might be empty or contain an identifier,
+ ;; depending on the setting of ABSTRACTP.
+
+ (parse (or (when (not (eq abstractp t))
+ (seq ((id :id)) (cons #'identity id)))
+ (when abstractp
+ (t (cons #'identity nil))))))
+
+ (argument-list ()
+ ;; [ ARGUMENT [ `,' ARGUMENT ]* ]
+
+ (parse (list ()
+ (seq ((base-type (parse-c-type scanner))
+ (dtor (parse-declarator scanner
+ base-type
+ :abstractp :maybe)))
+ (make-argument (cdr dtor) (car dtor)))
+ #\,)))
+
+ (postfix-lparen ()
+ ;; Postfix: `(' ARGUMENT-LIST `)'
+
+ (parse (seq (#\( (args (argument-list)) #\))
+ (postop "()" (state 9)
+ (cons (lambda (type)
+ (funcall (car state)
+ (make-function-type type args)))
+ (cdr state))))))
+
+ (dimension ()
+ ;; `[' C-FRAGMENT ']'
+
+ (parse-delimited-fragment scanner #\[ #\]))
+
+ (lbracket ()
+ ;; Postfix: DIMENSION+
+
+ (parse (seq ((dims (list (:min 1) (dimension))))
+ (postop "[]" (state 10)
+ (cons (lambda (type)
+ (funcall (car state)
+ (make-array-type type dims)))
+ (cdr state)))))))
+
+ ;; And now we actually do the declarator parsing.
+ (parse (seq ((value (expr (:nestedp nestedp)
+
+ ;; An actual operand.
+ (centre)
+
+ ;; Binary operators. There aren't any.
+ nil
+
+ ;; Prefix operators.
+ (or (star)
+ (prefix-lparen))
+
+ ;; Postfix operators.
+ (or (postfix-lparen)
+ (lbracket)
+ (when nestedp (seq (#\)) (rparen #\))))))))
+ (cons (funcall (car value) base-type) (cdr value)))))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parsing C fragments from a scanner
+;;;
+;;; (c) 2010 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Fragment parsing.
+
+(export 'scan-c-fragment)
+(defun scan-c-fragment (scanner end-chars)
+ "Parse a C fragment from the SCANNER.
+
+ SCANNER must be a `sod-token-scanner' instance.
+
+ The parsing process is a simple approximation to C lexical analysis. It
+ takes into account comments (both C and C++ style), string and character
+ literals."
+
+ (let ((char-scanner (token-scanner-char-scanner scanner))
+ (delim nil)
+ (stack nil))
+ (with-parser-context (character-scanner-context :scanner char-scanner)
+
+ ;; Hack. If the first character is a newline then discard it
+ ;; immediately. If I don't, then the output will look strange and the
+ ;; location information will be unhelpful.
+ (parse #\newline)
+
+ ;; This seems the easiest way of gathering stuff.
+ (with-scanner-place (place char-scanner)
+
+ (flet ((push-delim (d)
+ (push delim stack)
+ (setf delim d))
+
+ (result ()
+ (let* ((output (scanner-interval char-scanner place))
+ (end (position-if (lambda (char)
+ (or (char= char #\newline)
+ (not
+ (whitespace-char-p char))))
+ output :from-end t))
+ (trimmed (if end (subseq output 0 (1+ end)) "")))
+ (make-instance 'c-fragment
+ :location (file-location place)
+ :text trimmed))))
+
+ ;; March through characters until we reach the end.
+ (loop
+ (cond-parse (:consumedp cp :expected exp)
+
+ ;; Whitespace and comments are universally dull.
+ ((satisfies whitespace-char-p) (parse :whitespace))
+ ((scan-comment char-scanner))
+
+ ;; See if we've reached the end. There's a small trick here: I
+ ;; capture the result in the `if-char' consequent to ensure
+ ;; that we don't include the delimiter.
+ ((if-char () (and (null delim) (member it end-chars))
+ (values (result) t t)
+ (values end-chars nil nil))
+ (return (values it t t)))
+ (:eof
+ (lexer-error char-scanner '(:any) cp)
+ (return (values (result) t t)))
+
+ ;; Opening and closing brackets. Opening brackets push things
+ ;; onto a stack; closing brackets pop things off again.
+ (#\( (push-delim #\)))
+ (#\[ (push-delim #\]))
+ (#\{ (push-delim #\}))
+ ((or #\) #\] #\})
+ (if (eql it delim)
+ (setf delim (pop stack))
+ (cerror* "Unmatched `~C.'." it)))
+
+ ;; String and character literals.
+ ((seq ((quote (or #\" #\'))
+ (nil (skip-many ()
+ (or (and #\\ :any) (not quote))))
+ (nil (char quote)))))
+
+ ;; Anything else.
+ (:any)
+
+ ;; This really shouldn't be able to happen.
+ (t
+ (assert cp)
+ (lexer-error char-scanner exp cp)))))))))
+
+(export 'parse-delimited-fragment)
+(defun parse-delimited-fragment (scanner begin end)
+ "Parse a C fragment delimited by BEGIN and END.
+
+ The BEGIN and END arguments are characters. (Currently, BEGIN can be any
+ token type, but you probably shouldn't rely on this.)"
+
+ ;; This is decidedly nasty. The basic problem is that `scan-c-fragment'
+ ;; works at the character level rather than at the lexical level, and if we
+ ;; commit to the `[' too early then `scanner-step' will eat the first few
+ ;; characters of the fragment -- and then the rest of the parse will get
+ ;; horrifically confused.
+
+ (if (eql (token-type scanner) begin)
+ (multiple-value-prog1 (values (scan-c-fragment scanner (list end)) t t)
+ (scanner-step scanner))
+ (values (list begin) nil nil)))
+
+;;;----- That's all, folks --------------------------------------------------
Not a lot here, apart from a character scanner to read from and the
standard token scanner infrastructure."))
+(defmethod shared-initialize :after
+ ((scanner sod-token-scanner) slot-names &key)
+ (default-slot (scanner 'sod-parser::filename slot-names)
+ (scanner-filename (token-scanner-char-scanner scanner))))
+
;;;--------------------------------------------------------------------------
;;; Utilities.
(skip-many () (not #\newline))
(? #\newline))))))
+(defmethod make-scanner-stream ((scanner sod-token-scanner))
+ (make-scanner-stream (token-scanner-char-scanner scanner)))
+
;;;--------------------------------------------------------------------------
;;; Error reporting.
+(defvar *indicator-map* (make-hash-table)
+ "Hash table mapping indicator objects to human-readable descriptions.")
+
+(defun define-indicator (indicator description)
+ (setf (gethash indicator *indicator-map*) description)
+ indicator)
+
(export 'syntax-error)
(defun syntax-error (scanner expected &key (continuep t))
"Signal a (maybe) continuable syntax error."
(:ellipsis "`...'")
(t (format nil "<? ~S~@[ ~S~]>" type value)))))
(show-expected (thing)
- (cond ((atom thing) (show-token thing nil))
- ((eq (car thing) :id)
- (format nil "`~A'" (cadr thing)))
- (t (format nil "<? ~S>" thing)))))
+ (acond ((gethash thing *indicator-map*) it)
+ ((atom thing) (show-token thing nil))
+ ((eq (car thing) :id)
+ (format nil "`~A'" (cadr thing)))
+ (t (format nil "<? ~S>" thing)))))
(funcall (if continuep #'cerror* #'error)
"Syntax error: ~
- expected ~{#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
+ expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
but found ~A"
(mapcar #'show-expected expected)
(show-token (token-type scanner) (token-value scanner)))))
+(export 'lexer-error)
+(defun lexer-error (char-scanner expected consumedp)
+ "Signal a continuable lexical error."
+ (cerror* "Lexical error: ~
+ expected ~{~#[<bug>~;~A~;~A or ~A~;:~A, ~]~} ~
+ but found ~/sod::show-char/~
+ ~@[ at ~A~]"
+ (mapcar (lambda (exp)
+ (typecase exp
+ (character (format nil "~/sod::show-char/" exp))
+ (string (format nil "`~A'" exp))
+ ((cons (eql :digit) *) (format nil "<radix-~A digit>"
+ (cadr exp)))
+ ((eql :eof) "<end-of-file>")
+ ((eql :any) "<character>")
+ (t (format nil "<? ~S>" exp))))
+ expected)
+ (and (not (scanner-at-eof-p char-scanner))
+ (scanner-current-char char-scanner))
+ (and consumedp (file-location char-scanner))))
+
;;;--------------------------------------------------------------------------
;;; Token scanner protocol implementation.
(parse (many (acc init (+ (* acc radix) it) :min min)
(label (list :digit radix)
(filter (lambda (ch)
- (digit-char-p ch radix)))))))
-
- (lexer-error (expected consumedp)
- ;; Report a lexical error.
- (cerror* "Lexical error: ~
- expected ~{~#[<bug>~;~A~;~A or ~A~;:~A, ~]~} ~
- but found ~/sod::show-char/~
- ~@[ at ~A~]"
- (mapcar (lambda (exp)
- (typecase exp
- (character
- (format nil "~/sod::show-char/" exp))
- (string (format nil "`~A'" exp))
- ((cons (eql :digit) *)
- (format nil "<radix-~A digit>"
- (cadr exp)))
- ((eql :eof) "<end-of-file>")
- ((eql :any) "<character>")
- (t (format nil "<? ~S>" exp))))
- expected)
- (and (not (scanner-at-eof-p char-scanner))
- (scanner-current-char char-scanner))
- (and consumedp (file-location char-scanner)))))
+ (digit-char-p ch radix))))))))
;; Skip initial junk, and remember the place.
(loop
(cond-parse (:consumedp cp :expected exp)
((satisfies whitespace-char-p) (parse :whitespace))
((scan-comment char-scanner))
- (t (if cp (lexer-error exp cp) (return)))))
+ (t (if cp (lexer-error char-scanner exp cp) (return)))))
;; Now parse something.
(cond-parse (:consumedp cp :expected exp)
;; Report errors and try again. Because we must have consumed some
;; input in order to get here (we've matched both :any and :eof) we
;; must make progress on every call.
- (t (assert cp) (lexer-error exp cp) (scanner-token scanner)))))))
+ (t
+ (assert cp)
+ (lexer-error char-scanner exp cp)
+ (scanner-token scanner)))))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Top-level parser for module syntax
+;;;
+;;; (c) 2010 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Toplevel syntax.
+
+(export 'module)
+
+;;; Type names.
+
+(define-pluggable-parser module typename (scanner)
+ ;; `typename' ID ( `,' ID )* `;'
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (and "typename"
+ (skip-many (:min 1)
+ (seq ((id :id))
+ (if (gethash id *module-type-map*)
+ (cerror* "Type `~A' already defined" id)
+ (add-to-module *module*
+ (make-instance 'type-item
+ :name id))))
+ #\,)
+ #\;))))
+
+;;; Fragments.
+
+(define-pluggable-parser module code (scanner)
+ ;; `code' ID `:' ID [ CONSTRAINTS ] `{' C-FRAGMENT `}'
+
+ (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))))))
+
+;;; External files.
+
+(defun read-module (pathname &key (truename (truename pathname)) 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
+ the file's TRUENAME already (e.g., because `probe-file' dropped it into
+ your lap) so you can avoid repeating the search by providing it.
+
+ The LOCATION is the thing which wanted the module imported -- usually a
+ `file-location' object, though it might be anything other than `t' which
+ can be printed in the event of circular imports."
+
+ (define-module (pathname :location location :truename truename)
+ (with-open-file (f-stream pathname :direction :input)
+ (let* ((*readtable* (copy-readtable))
+ (char-scanner (make-instance 'charbuf-scanner
+ :stream f-stream))
+ (scanner (make-instance 'sod-token-scanner
+ :char-scanner char-scanner)))
+ (with-default-error-location (scanner)
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (skip-many () (plug module scanner)))))))))
+
+(define-pluggable-parser module test (scanner)
+ ;; `demo' STRING `;'
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (seq ("demo" (string :string) #\;)
+ (format t ";; DEMO ~S~%" string)))))
+
+(define-pluggable-parser module file (scanner)
+ ;; `import' STRING `;'
+ ;; `load' STRING `;'
+
+ (flet ((common (name type what thunk)
+ (find-file scanner
+ (merge-pathnames name
+ (make-pathname :type type
+ :case :common))
+ what
+ thunk)))
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (or (seq ("import" (name :string) #\;)
+ (common name "SOD" "module"
+ (lambda (path true)
+ (handler-case
+ (let ((module (read-module path
+ :truename true)))
+ (when module
+ (module-import module)
+ (pushnew module
+ (module-dependencies
+ *module*))))
+ (file-error (error)
+ (cerror* "Error reading module ~S: ~A"
+ path error))))))
+ (seq ("load" (name :string) #\;)
+ (common name "LISP" "Lisp file"
+ (lambda (path true)
+ (handler-case
+ (load true :verbose nil :print nil)
+ (error (error)
+ (cerror* "Error loading Lisp file ~S: ~A"
+ path error)))))))))))
+
+;;; Lisp escape.
+
+(define-pluggable-parser module lisp (scanner)
+ ;; `lisp' s-expression `;'
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (seq ((sexp (if (and (eql (token-type scanner) :id)
+ (string= (token-value scanner) "lisp"))
+ (let* ((stream (make-scanner-stream scanner))
+ (sexp (read stream t)))
+ (scanner-step scanner)
+ (values sexp t t))
+ (values '((:id "lisp")) nil nil)))
+ #\;)
+ (eval sexp)))))
+
+;;;--------------------------------------------------------------------------
+;;; Class declarations.
+
+(define-pluggable-parser module class (scanner)
+ ;; `class' id [`:' id-list] `{' class-item* `}'
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (seq ("class"
+ (name :id)
+ (supers (? (seq (#\: (supers (list (:min 1) :id #\,)))
+ supers)))
+ #\{
+
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parsing property sets
+;;;
+;;; (c) 2012 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defun play (args)
+ "Parse and evaluate a simple expression.
+
+ The result is a pair (TYPE . VALUE). Currently, type types are `:id',
+ `:int', `:string', and `:char'. If an error prevented a sane ; value from
+ being produced, the type `:invalid' is returned.
+
+ The syntax of expressions is rather limited at the moment, but more may be
+ added later.
+
+ expression: term | expression `+' term | expression `-' term
+ term: factor | term `*' factor | term `/' factor
+ factor: primary | `+' factor | `-' factor
+ primary: int | id | string | `(' expression `)' | `?' lisp-expression
+
+ Only operators for dealing with integers are provided."
+
+ (labels ((type-dispatch (name args &rest spec)
+ (acond ((find :invalid args :key #'car)
+ (cons :invalid nil))
+ ((find-if (lambda (item)
+ (every (lambda (type arg)
+ (eql type (car arg)))
+ (cddr item)
+ args))
+ spec)
+ (cons (car it) (apply (cadr it)
+ (mapcar #'cdr args))))
+ (t
+ (cerror* "Type mismatch: operator `~A' applied to ~
+ types ~{~(~A~)~#[~; and ~;, ~]~}"
+ name
+ (mapcar #'car args))
+ (cons :invalid nil))))
+ (add (x y) (type-dispatch "+" (list x y)
+ (list :integer #'+ :integer :integer)))
+ (sub (x y) (type-dispatch "-" (list x y)
+ (list :integer #'- :integer :integer)))
+ (mul (x y) (type-dispatch "*" (list x y)
+ (list :integer #'* :integer :integer)))
+ (div (x y) (type-dispatch "/" (list x y)
+ (list :integer
+ (lambda (x y)
+ (cond ((zerop y)
+ (cerror*
+ "Division by zero")
+ (cons :invalid nil))
+ (t
+ (floor x y))))
+ :integer :integer)))
+ (nop (x) (type-dispatch "+" (list x)
+ (list :integer #'+ :integer)))
+ (neg (x) (type-dispatch "-" (list x)
+ (list :integer #'- :integer))))
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (expr (lisp (flet ((prop (type value)
+ (scanner-step scanner)
+ (values (cons type value) t t)))
+ (case (token-type scanner)
+ (:int
+ (prop :integer (token-value scanner)))
+ ((:id :char :string)
+ (prop (token-type scanner) (token-value scanner)))
+ (#\?
+ (let* ((stream (make-scanner-stream scanner))
+ (sexp (read stream t)))
+ (scanner-step scanner)
+ (values (cons (property-type sexp) sexp)
+ t t)))
+ (t
+ (values (list :int :id :char :string #\?)
+ nil nil)))))
+
+
+(defun parse-property (scanner pset)
+ "Parse a single property using the SCANNER; add it to the PSET."
+ ;; id `=' expression
+
+;;;----- That's all, folks --------------------------------------------------
(default-slot (operator 'rprec slot-names)
(slot-value operator 'lprec))))
-(defmethod shared-initialize :after
- ((operator simple-binary-operator) slot-names &key)
- (when (slot-boundp operator 'lprec)
- (default-slot (operator 'rprec slot-names)
- (slot-value operator 'lprec))))
-
(defmethod push-operator
((operator prefix-operator) (state expression-parse-state))
;;; Main expression parser implementation.
(defun parse-expression (p-operand p-binop p-preop p-postop)
+ "Parse an expression consisting of operands and various kinds of operators.
+
+ The arguments are all parser functions: they will be called with one
+ argument NESTEDP, which indicates whether the parse has encountered an
+ unmatched parenthesis."
+
(let ((state (make-instance 'expression-parse-state))
(consumed-any-p nil))
(unread :initform nil :type (or charbuf-chain-link nil))
(filename :initarg :filename :type (or string null)
:reader scanner-filename)
- (line :initarg line :initform 1 :type fixnum :reader scanner-line)
+ (line :initarg :line :initform 1 :type fixnum :reader scanner-line)
(column :initarg :column :initform 0 :type fixnum :reader scanner-column))
(:documentation
"An efficient rewindable scanner for character streams.
(defclass charbuf-scanner-stream (character-scanner-stream)
((scanner :initarg :scanner :type charbuf-scanner)))
+(defmethod make-scanner-stream ((scanner charbuf-scanner))
+ (make-instance 'charbuf-scanner-stream :scanner scanner))
+
(defmethod stream-read-sequence
((stream charbuf-scanner-stream) (seq string) &optional (start 0) end)
(with-slots (scanner) stream
(defmethod scanner-step ((scanner token-scanner))
(with-slots (type value tail captures line column) scanner
- (cond (tail
- (let ((next (token-scanner-place-next tail)))
- (setf type (token-scanner-place-type next)
- value (token-scanner-place-value next)
- line (token-scanner-place-line next)
- column (token-scanner-place-column next)
- tail next)))
- (t
- (multiple-value-bind (ty val) (scanner-token scanner)
- (setf type ty
- value val)
- (when (plusp captures)
- (let ((next (make-token-scanner-place
- :type ty :value val :line line :column column)))
- (setf (token-scanner-place-next tail) next
- tail next))))))))
+ (acond ((and tail (token-scanner-place-next tail))
+ (setf type (token-scanner-place-type it)
+ value (token-scanner-place-value it)
+ line (token-scanner-place-line it)
+ column (token-scanner-place-column it)
+ tail it))
+ (t
+ (multiple-value-bind (ty val) (scanner-token scanner)
+ (setf type ty
+ value val)
+ (if (plusp captures)
+ (let ((next (make-token-scanner-place
+ :type ty :value val
+ :line line :column column)))
+ (setf (token-scanner-place-next tail) next
+ tail next))
+ (setf tail nil)))))))
(defmethod scanner-capture-place ((scanner token-scanner))
(with-slots (type value captures tail line column) scanner
This should apply existing stacked operators as necessary to obey the
language's precedence rules."))
-(export 'push-vlaue)
+(export 'push-value)
(defgeneric push-value (value state)
(:documentation
"Push VALUE onto the STATE's value stack.
(export 'expr)
(defparse expr ((&key (nestedp (gensym "NESTEDP-")))
operand binop preop postop)
- "Parse an expression involving unary and binary operators."
+ "Parse an expression involving unary and binary operators.
+
+ Within the parsers for operands and operators, the variable NESTEDP is
+ bound to a generalized boolean which is true if an unmatched open-
+ parenthesis has been seen.
+
+ The OPERAND parser should produce a value; the various operator parsers
+ (BINOP, PREOP, and POSTOP) should produce objects obeying the `operator'
+ protocol. The final output of the `expr' parse is the result of
+ evaluating the parsed expression. (Of course, the definition of
+ `evaluation' here is determined entirely by the methods on
+ `apply-operator', so the final value may be a parse tree, for example.)"
+
(flet ((wrap (parser)
`(parser (,nestedp)
(declare (ignorable ,nestedp))
Higher precedence numbers indicate tighter rightward binding. Under the
default method for `operator-push-action', a new operator's left
- precedence may be compared to the existing OPERATOR'S right precedences to
+ precedence may be compared to the existing OPERATOR's right precedences to
determine the parser's behaviour: if it is higher, then the new operator
is pushed; otherwise the existing OPERATOR is applied. Thus, equal
precedences cause left-associative parsing."))
(export 'preop)
(defmacro preop (name (x prec) &body body)
+ "Define a prefix operator.
+
+ The operator will be called NAME in error messages, and have right
+ precedence PREC. To apply the operator, BODY is evaluated with X bound to
+ the operand."
+
`(make-instance 'simple-prefix-operator
:name ,name
:precedence ,prec
(export 'postop)
(defmacro postop (name (x prec &key rprec) &body body)
+ "Define a postfix operator.
+
+ The operator will be called NAME in error messages, and have left
+ precedence PREC and right precendence RPREC (defaulting to PREC). To
+ apply the operator, BODY is evaluated with X bound to the operand."
+
(once-only (name prec rprec)
`(make-instance 'simple-postfix-operator
:name ,name
(export 'binop)
(defmacro binop (name (x y prec &key rprec (assoc :left)) &body body)
+ "Define a binary operator.
+
+ The operator will be called NAME in error messages, and have left
+ precedence PREC and right precedence RPREC (defaulting to PREC, implying
+ left associativity under the default `operator-push-action'
+ implementation. To apply the operator, BODY is evaluated with X and Y
+ bound to the operands in the order they were parsed"
+
(once-only (name prec rprec assoc)
`(make-instance 'simple-binary-operator
:name ,name
;;; The functions and macros here are simply ways of gluing together
;;; expressions which obey this protocol.
;;;
-;;; The main contribution of this file is a macro WITH-PARSER-CONTEXT which
+;;; The main contribution of this file is a macro `with-parser-context' which
;;; embeds a parsing-specific S-expressions language entered using the new
-;;; macro PARSE. The behaviour of this macro is controlled by a pair of
-;;; compile-time generic functions EXPAND-PARSER-SPEC and EXPAND-PARSER-FORM.
-;;; As well as the parser expression they're meant to process, these
-;;; functions dispatch on a `context' argument, which is intended to help
-;;; `leaf' parsers find the terminal symbols which they're meant to process.
+;;; macro `parse'. The behaviour of this macro is controlled by a pair of
+;;; compile-time generic functions `expand-parser-spec' and
+;;; `expand-parser-form'. As well as the parser expression they're meant to
+;;; process, these functions dispatch on a `context' argument, which is
+;;; intended to help `leaf' parsers find the terminal symbols which they're
+;;; meant to process.
;;;
-;;; Note that the context is a compile-time object, constructed by the PARSE
-;;; macro expansion function, though the idea is that it will contain the
-;;; name or names of variables holding the run-time parser state (which will
-;;; typically be a lexical analyser or an input stream or suchlike).
+;;; Note that the context is a compile-time object, constructed by the
+;;; `parse' macro expansion function, though the idea is that it will contain
+;;; the name or names of variables holding the run-time parser state (which
+;;; will typically be a lexical analyser or an input stream or suchlike).
(cl:in-package #:sod-parser)
"Succeed, without consuming input, with result VALUE."
`(values ,value t nil))
+(defparse nil (indicator)
+ "Fail, without consuming input, with indicator VALUE."
+ `(values (list ,indicator) nil nil))
+
(defparse when (cond &body parser)
"If CONDITION is true, then match PARSER; otherwise fail."
`(if ,cond (parse ,@parser) (values nil nil nil)))
"Always matches without consuming input."
'(values t t nil))
+(defmethod expand-parser-spec (context (spec (eql nil)))
+ "Always fails without consuming input. The failure indicator is `:fail'."
+ '(values '(:fail) nil nil))
+
(export 'seq)
(defparse seq (binds &body body)
"Parse a sequence of heterogeneous items.
The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'-
comparable object which identifies the element. Neither SYMBOL nor TAG is
evaluated. The BODY is a parser expression; the BVL is a lambda list
- describing how to bind the argumens supplied via `pluggable-parser'.
+ describing how to bind the arguments supplied via `pluggable-parser'.
If a parser with the given TAG is already attached to SYMBOL then the new
parser replaces the old one; otherwise it is added to the collection."
you must check this first. Be careful: all of this is happening at
macro-expansion time."))
+(export 'if-char)
(defparse if-char (:context (context character-parser-context)
(&optional (char 'it)) condition consequent alternative)
"Basic character-testing parser.
If there is a current character, bind it to CHAR and evaluate the
- CONDITION; if that is true, then step the parser and evaluate CONSEQUENT;
- otherwise, if either we're at EOF or the CONDITION returns false, evaluate
- ALTERNATIVE. The result of `if-char' are the values returned by
- CONSEQUENT or ALTERNATIVE."
+ CONDITION; if that is true, then evaluate CONSEQUENT and step the parser
+ (in that order); otherwise, if either we're at EOF or the CONDITION
+ returns false, evaluate ALTERNATIVE. The result of `if-char' are the
+ values returned by CONSEQUENT or ALTERNATIVE."
(with-gensyms (block)
`(block ,block
(unless ,(parser-at-eof-p context)
(let ((,char ,(parser-current-char context)))
(when ,condition
- ,(parser-step context)
- (return-from ,block ,consequent))))
+ (return-from ,block
+ (multiple-value-prog1 ,consequent
+ ,(parser-step context))))))
,alternative)))
(defmethod expand-parser-spec
state. So the scanner context is a compile-time context which expands to
calls to use the run-time scanner. See?
- This class provides common compile-time behaviour for PARSER-AT-EOF-P and
- friends by invoking corresponding methods on the scanner object at
+ This class provides common compile-time behaviour for `parser-at-eof-p'
+ and friends by invoking corresponding methods on the scanner object at
run-time."))
;;;--------------------------------------------------------------------------
(next nil :type (or token-scanner-place null))
(type nil :read-only t)
(value nil :read-only t)
- (line 1 :type fixnum :read-only t)
- (column 0 :type fixnum :read-only t))
+ (line 1 :type (or fixnum null) :read-only t)
+ (column 0 :type (or fixnum null) :read-only t))
;; The token scanner base class and parser context.
(value :reader token-value)
(captures :initform 0 :type fixnum)
(tail :initform nil :type (or token-scanner-place null))
- (filename :initarg filename :type string :reader scanner-filename)
+ (filename :initarg :filename :type string :reader scanner-filename)
(line :initarg :line :initform 1 :type fixnum :accessor scanner-line)
(column :initarg :column :initform 0
:type fixnum :accessor scanner-column))
`stream-read-sequence' and `stream-read-line' in a scanner-specific
manner."))
+(export 'make-scanner-stream)
+(defgeneric make-scanner-stream (scanner)
+ (:documentation
+ "Return a stream which reads from the SCANNER.
+
+ The default method simply constructs a `character-scanner-stream'
+ instance. Subclasses of `character-scanner' can override this method in
+ order to return instances of more efficient stream subclasses.")
+ (:method ((scanner character-scanner))
+ (make-instance 'character-scanner-stream :scanner scanner)))
+
;;;----- That's all, folks --------------------------------------------------
"Return a canonical list of qualifiers."
(delete-duplicates (sort (copy-list qualifiers) #'string<)))
+(export 'qualify-c-type)
+(defgeneric qualify-c-type (type qualifiers)
+ (:documentation
+ "Return a type like TYPE but with the specified QUALIFIERS.
+
+ The qualifiers of the returned type are the union of the requested
+ QUALIFIERS and the qualifiers already applied to TYPE."))
+
(export 'c-type-subtype)
(defgeneric c-type-subtype (type)
(:documentation
the end of its input stream by setting the lookahead character to nil. At
this point it is still possible to push back characters."))
-(export '(token-type token-value))
-(defgeneric token-type (lexer)
- (:documentation
- "Return the type of the LEXER's current lookahead token
-
- When the lexer is first created, there is no lookahead token: you must
- `prime the pump' by calling NEXT-TOKEN."))
-(defgeneric token-value (lexer)
- (:documentation
- "Return the value of the LEXER's current lookahead token
-
- When the lexer is first created, there is no lookahead token: you must
- `prime the pump' by calling NEXT-TOKEN."))
-
;;;--------------------------------------------------------------------------
;;; Formatting tokens.
This is not a useful class by itself. Message classes are expected to
define their own effective-method classes.
- An effective method classce must accept a `:direct-methods' initarg, which
+ An effective method class must accept a `:direct-methods' initarg, which
will be a list of applicable methods sorted in most-to-least specific
order. (Either that or you have to add an overriding method to
`compute-sod-effective-method'."))
(invoke (chain target)
(if (null chain)
(funcall kernel target)
- (let* ((trampoline (next-trampoline (car chain)
- (cdr chain))))
+ (let ((trampoline (next-trampoline (car chain)
+ (cdr chain))))
(invoke-method codegen target
(cons trampoline argument-tail)
(car chain))))))
(defparameter *module* nil
"The current module under construction.
- This is always an instance of MODULE. Once we've finished constructing
- it, we'll call `change-class' to turn it into an instance of whatever type
- is requested in the module's `:lisp-class' property.")
+ During module construction, this is always an instance of `module'. Once
+ we've finished constructing it, we'll call `change-class' to turn it into
+ an instance of whatever type is requested in the module's `:lisp-class'
+ property.")
(export 'module-import)
(defgeneric module-import (object)
particular, it will change the class (using `change-class') of the module
according to the class choice set in the module's `:lisp-class' property.
This has the side effects of calling `shared-initialize', setting the
- module's state to T, and checking for unrecognized properties. (Therefore
- subclasses should add a method to `shared-initialize' taking care of
- looking at interesting properties, just to make sure they're ticked
- off.)"))
+ module's state to `t', and checking for unrecognized
+ properties. (Therefore subclasses should add a method to
+ `shared-initialize' taking care of looking at interesting properties, just
+ to make sure they're ticked off.)"))
;;;--------------------------------------------------------------------------
;;; Module objects.
(defmacro define-module
((name &key (truename nil truenamep) (location nil locationp))
&body body)
- "Define a new module.
+ "Define and return a new module.
- The module will be called NAME; it will be included in the *module-map*
+ The module will be called NAME; it will be included in the `*module-map*'
only if it has a TRUENAME (which defaults to the truename of NAME, or nil
if there is no file with that name). The module is populated by
- evaluating the BODY in a dynamic environment where *module* is bound to
+ evaluating the BODY in a dynamic environment where `*module*' is bound to
the module under construction, and any other module variables are bound to
appropriate initial values -- see `*module-bindings-alist*' and
`define-module-var'.
+ If a module with the same NAME is already known, then it is returned
+ unchanged: the BODY is not evaluated.
+
+ The LOCATION may be any printable value other than `t' (though
+ `file-location' objects are most usual) indicating what provoked this
+ module definition: it gets reported to the user if an import cycle is
+ detected. This check is made only if a TRUENAME is supplied.
+
Evaluation order irregularity: the TRUENAME and LOCATION arguments are
always evaluated in that order, regardless of their order in the macro
- call site."
+ call site (which this macro can't detect)."
`(build-module ,name
(lambda () ,@body)
sequencer items and stores them in its table indexed by name. Secondly,
it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly,
it can be instructed to invoke the items in an order compatible with the
- established constraints.
-
- Sequencer item names may may any kind of object which can be compared with
- EQUAL. In particular, symbols, integers and strings are reasonable
- choices for atomic names, and lists work well for compound names -- so
- it's possible to construct a hierarchy."))
+ established constraints."))
(export 'ensure-sequencer-item)
(defgeneric ensure-sequencer-item (sequencer name)
(:documentation
"Arrange that SEQUENCER has a sequencer-item called NAME.
- Returns the corresponding SEQUENCER-ITEM object."))
+ Returns the corresponding SEQUENCER-ITEM object.
+
+ Sequencer item names may may any kind of object which can be compared with
+ EQUAL. In particular, symbols, integers and strings are reasonable
+ choices for atomic names, and lists work well for compound names -- so
+ it's possible to construct a hierarchy."))
(export 'add-sequencer-constraint)
(defgeneric add-sequencer-constraint (sequencer constraint)
The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
can be matched using an EQL-specializer. In response, OBJECT should add
- any constrains and item functions that it wishes, and pass the
+ any constraints and item functions that it wishes, and pass the
announcement to its sub-objects. It is not uncommon for an object to pass
a reason to its sub-objects that is different from the REASON with which
it was itself invoked.")
The full syntax isn't quite as described:
sequence-output (STREAMVAR SEQUENCER)
- { :constrant CONSTRAINT }*
+ { :constraint CONSTRAINT }*
CLAUSE*
STREAMVAR ::= a symbol
An ITEM-NAME may be a self-evaluating atom (in which case it stands for
itself, clearly), a symbol (in which case the corresponding variable value
- is used) or a list of forms (in which case the name used is the list of
+ is used), or a list of forms (in which case the name used is the list of
the corresponding values).
The behaviour is as follows. The CONSTRAINTS, if any, are added to the
;; The actual tests.
(:file "test-c-types" :depends-on ("test-base"))
- (:file "test-codegen" :depends-on ("test-base"))))
+ (:file "test-codegen" :depends-on ("test-base"))
+ (:file "test-lexer" :depends-on ("test-base"))))
;;;--------------------------------------------------------------------------
;;; Testing.
;; Property set protocol.
(:file "proto-pset" :depends-on ("package"))
(:file "impl-pset" :depends-on ("proto-pset"))
+ (:file "parse-pset" :depends-on ("proto-pset" "parse-lexical"))
;; Lexical analysis.
- ;;(:file "proto-lexer" :depends-on ("parser"))
- ;;(:file "impl-lexer" :depends-on ("proto-lexer"))
+ (:file "parse-lexical" :depends-on ("parser"))
+ (:file "parse-fragment" :depends-on ("parse-lexical"))
;; Code generation protocol.
(:file "proto-codegen" :depends-on ("package"))
("proto-module" "proto-pset" "impl-c-types-class" "builtin"))
(:file "builtin" :depends-on ("proto-module" "proto-pset" "classes"
"impl-c-types" "impl-c-types-class"))
+ (:file "parse-module" :depends-on ("impl-module"
+ "parse-lexical" "parse-fragment"))
;; Output.
(:file "proto-output" :depends-on ("package"))
rather than `~A'."
object print string))))
-(defun run-tests ()
- (textui-test-run *sod-test-suite*))
+(defun run-tests (&optional which)
+ (textui-test-run (acond
+ ((null which) *sod-test-suite*)
+ ((labels ((dredge (suite)
+ (cond
+ ((typep suite 'test-suite)
+ (some #'dredge (tests suite)))
+ ((eq (xlunit::name suite) which)
+ suite)
+ (t
+ nil))))
+ (dredge *sod-test-suite*))
+ it)
+ ((find-class which nil)
+ (suite (make-instance it)))
+ (t
+ (error "Don't know how to turn ~S into a test suite"
+ which)))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Test lexical analyser
+;;;
+;;; (c) 2010 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-test)
+
+(defclass lexer-test (test-case) ())
+(add-test *sod-test-suite* (get-suite lexer-test))
+
+;;;--------------------------------------------------------------------------
+;;; Simple lexical analysis tests.
+
+(defun list-tokens (string)
+ (let ((lexer (make-instance 'sod-token-scanner
+ :char-scanner (make-string-scanner string)
+ :filename "<string>")))
+ (with-parser-context (token-scanner-context :scanner lexer)
+ (parse (list () (if (scanner-at-eof-p lexer) (values '(:eof) nil nil)
+ (multiple-value-prog1
+ (values (cons (token-type lexer)
+ (token-value lexer))
+ t t)
+ (scanner-step lexer))))))))
+
+(defmacro assert-tokens (string &rest list)
+ `(assert-equal (list-tokens ,string) ',list))
+
+(def-test-method simple-lexer ((test lexer-test) :run nil)
+ (assert-tokens "foo - bar"
+ (:id . "foo")
+ (#\- . nil)
+ (:id . "bar")))
+
+;;;----- That's all, folks --------------------------------------------------
`(let ((it ,cond)) (when it ,@body)))
(export 'acond)
-(defmacro acond (&rest clauses &environment env)
+(defmacro acond (&body clauses &environment env)
"Like COND, but with `it' bound to the value of the condition.
Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is
;;;--------------------------------------------------------------------------
;;; MOP hacks (not terribly demanding).
+(export 'instance-initargs)
+(defgeneric instance-initargs (instance)
+ (:documentation
+ "Return a plausble list of initargs for INSTANCE.
+
+ The idea is that you can make a copy of INSTANCE by invoking
+
+ (apply #'make-instance (class-of INSTANCE)
+ (instance-initargs INSTANCE))
+
+ The default implementation works by inspecting the slot definitions and
+ extracting suitable initargs, so this will only succeed if enough slots
+ actually have initargs specified that `initialize-instance' can fill in
+ the rest correctly.
+
+ The list returned is freshly consed, and you can destroy it if you like.")
+ (:method ((instance standard-object))
+ (mapcan (lambda (slot)
+ (aif (slot-definition-initargs slot)
+ (list (car it)
+ (slot-value instance (slot-definition-name slot)))
+ nil))
+ (class-slots (class-of instance)))))
+
(export '(copy-instance copy-instance-using-class))
(defgeneric copy-instance-using-class (class instance &rest initargs)
(:documentation
"Composition of functions. Functions are applied left-to-right.
This is the reverse order of the usual mathematical notation, but I find
- it easier to read. It's also slightly easier to work with in programs."
+ it easier to read. It's also slightly easier to work with in programs.
+ That is, (compose F1 F2 ... Fn) is what a category theorist might write as
+ F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn."
+
(labels ((compose1 (func-a func-b)
(lambda (&rest args)
(multiple-value-call func-b (apply func-a args)))))
~mdw / sod / commitdiff