(export '(c-function-type c-function-arguments))
(defclass c-function-type (c-type)
((subtype :initarg :subtype :type c-type :reader c-type-subtype)
- (arguments :initarg :arguments :type list :reader c-function-arguments))
+ (arguments :type list :reader c-function-arguments))
(:documentation
"C function types. The subtype is the return type, as implied by the C
syntax for function declarations."))
+(defmethod shared-initialize :after
+ ((type c-function-type) slot-names &key (arguments nil argsp))
+ (declare (ignore slot-names))
+ (when argsp
+ (setf (slot-value type 'arguments)
+ (if (and arguments
+ (null (cdr arguments))
+ (not (eq (car arguments) :ellipsis))
+ (eq (argument-type (car arguments)) c-type-void))
+ nil
+ arguments))))
+
;; Constructor function.
(export 'make-function-type)
(defun make-function-type (subtype arguments)
"Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
(make-instance 'c-function-type :subtype subtype
- :arguments (if (and arguments
- (null (cdr arguments))
- (not (eq (car arguments) :ellipsis))
- (eq (argument-type (car arguments))
- c-type-void))
- nil
- arguments)))
+ :arguments arguments))
;; Comparison protocol.
"Produce a `commentified' version of the argument.
The default behaviour is that temporary argument names are simply omitted
- (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
+ (nil is returned); otherwise, `/*...*/' markers are wrapped around the
printable representation of the argument.")
(:method ((name null)) nil)
(:method ((name t)) (format nil "/*~A*/" name)))
;;;--------------------------------------------------------------------------
;;; Classes.
+(defun maximum (items order what)
+ "Return a maximum item according to the non-strict partial ORDER."
+ (reduce (lambda (best this)
+ (cond ((funcall order best this) best)
+ ((funcall order this best) this)
+ (t (error "Unable to choose best ~A." what))))
+ items))
+
(defmethod guess-metaclass ((class sod-class))
"Default metaclass-guessing function for classes.
Return the most specific metaclass of any of the CLASS's direct
superclasses."
- (do ((supers (sod-class-direct-superclasses class) (cdr supers))
- (meta nil (let ((candidate (sod-class-metaclass (car supers))))
- (cond ((null meta) candidate)
- ((sod-subclass-p meta candidate) meta)
- ((sod-subclass-p candidate meta) candidate)
- (t (error "Unable to choose metaclass for `~A'"
- class))))))
- ((endp supers) meta)))
+ (maximum (mapcar #'sod-class-metaclass
+ (sod-class-direct-superclasses class))
+ #'sod-subclass-p
+ (format nil "metaclass for `~A'" class)))
(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
"Specific behaviour for SOD class initialization.
;; If no metaclass, guess one in a (Lisp) class-specific way.
(default-slot-from-property (class 'metaclass slot-names)
(pset :metaclass :id meta (find-sod-class meta))
- (guess-metaclass class))
+ (and (sod-class-direct-superclasses class)
+ (guess-metaclass class)))
;; If no chain-link, then start a new chain here.
(default-slot-from-property (class 'chain-link slot-names)
(with-default-error-location (location)
(let* ((pset (property-set pset))
- (class (make-instance (get-property pset :lisp-metaclass :symbol
- 'sod-class)
+ (best-class (or (get-property pset :lisp-metaclass :symbol nil)
+ (if superclasses
+ (maximum (mapcar #'class-of superclasses)
+ #'subtypep
+ (format nil "Lisp metaclass for ~A"
+ name))
+ 'sod-class)))
+ (class (make-instance best-class
:name name
:superclasses superclasses
:location (file-location location)
((in-use-p :initarg :in-use-p :initform nil
:type boolean :accessor var-in-use-p)))
+(define-module-var *temporary-index* 0
+ "Index for temporary name generation.
+
+ 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.")
+
+(define-clear-the-decks reset-codegen-index
+ (setf *temporary-index* 0))
+
(defmethod commentify-argument-name ((name temporary-name))
nil)
;; package. The `definst' machinery will symbolicate the various associated
;; methods correctly despite this subterfuge.
-(definst if (stream :export t) (#1=#:condition consequent alternative)
- (format-compound-statement (stream consequent alternative)
+(definst if (stream :export t) (#1=#:cond conseq alt)
+ (format-compound-statement (stream conseq alt)
(format stream "if (~A)" #1#))
- (when alternative
- (format-compound-statement (stream alternative)
+ (when alt
+ (format-compound-statement (stream alt)
(write-string "else" stream))))
-(definst while (stream :export t) (#1=#:condition body)
+(definst while (stream :export t) (#1=#:cond body)
(format-compound-statement (stream body)
(format stream "while (~A)" #1#)))
-(definst do-while (stream :export t) (body #1=#:condition)
+(definst do-while (stream :export t) (body #1=#:cond)
(format-compound-statement (stream body :space)
(write-string "do" stream))
(format stream "while (~A);" #1#))
(:documentation
"Base class for temporary variable and argument names."))
-;; Important variables.
-
-(defparameter *temporary-index* 0
- "Index for temporary name generation.
-
- 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.")
-
-(define-clear-the-decks reset-codegen-index
- (setf *temporary-index* 0))
-
;; Important temporary names.
(export '(*sod-ap* *sod-master-ap*))
+++ /dev/null
-(cl:in-package #:sod)
-
-(defun play-fetch-token (string)
- (with-parser-context (string-parser :string string)
- (labels ((digit (radix)
- (parse (filter (lambda (ch)
- (digit-char-p ch radix)))))
- (number (radix &optional (initial 0))
- (parse (many (a initial (+ (* radix a) it))
- (digit radix))))
- (numeric (radix sigil)
- (parse (seq ((first (peek (seq ((nil (funcall sigil))
- (d (digit radix)))
- d)))
- (result (number radix first)))
- result))))
- (multiple-value-call #'values
- (loop
- (parse :whitespace)
-
- (cond-parse ()
-
- ;; Give up at end-of-file.
- (:eof
- (return (values :eof nil)))
-
- ;; Pick out comments.
- ((peek (and #\/ #\*))
- (parse (skip-many () ; this may fail at eof; don't worry
- (and (skip-many () (not #\*))
- (skip-many (:min 1) #\*))
- (not #\/)))
- (if-parse :eof ()
- (cerror* "Unterminated comment")
- (parse :any)))
- ((and (peek (seq (#\/ #\/)))
- (skip-many () (not #\newline))
- (or :eof #\newline)))
-
- ;; Quoted strings and characters.
- ((or #\' #\")
- (let ((quote it)
- (out (make-string-output-stream)))
- (parse (skip-many ()
- (or (seq ((ch (satisfies (lambda (ch)
- (and (char/= ch #\\)
- (char/= ch quote))))))
- (write-char ch out))
- (seq (#\\ (ch :any))
- (write-char ch out)))))
- (if-parse :eof ()
- (cerror* "Unterminated ~:[string~;character~] constant"
- (char= quote #\'))
- (parse :any))
- (let ((string (get-output-stream-string out)))
- (ecase quote
- (#\" (return (values :string string)))
- (#\' (case (length string)
- (0 (cerror* "Empty character constant")
- (return (values :char #\?)))
- (1 (return (values :char (char string 0))))
- (t (cerror* "Multiple characters in ~
- character constant")
- (return (values :char (char string 0))))))))))
-
- ;; Identifiers.
- ((seq ((first (satisfies (lambda (ch)
- (or (char= ch #\_)
- (alpha-char-p ch)))))
- (ident (many (out (let ((s (make-string-output-stream)))
- (write-char first s)
- s)
- (progn (write-char it out) out)
- :final (get-output-stream-string out))
- (satisfies (lambda (ch)
- (or (char= ch #\_)
- (alphanumericp ch)))))))
- (return (values :id ident))))
-
- ;; Numbers -- uses the machinery in the labels above.
- ((or (seq (#\0
- (i (or (numeric 8 (parser () (or #\o #\O)))
- (numeric 16 (parser () (or #\x #\X)))
- (number 8))))
- i)
- (seq ((first (digit 10))
- (rest (number 10 first)))
- rest))
- (return (values :integer it)))
-
- ;; Special separator tokens.
- ("..."
- (return (values :ellipsis :ellipsis)))
-
- ;; Anything else is a standalone delimiter character.
- (:any
- (return (values it it)))))
- (parse (list () :any))))))
(do-case2-like 'ecase vform clauses))
;;;--------------------------------------------------------------------------
-;;; Locatives.
-
-(export '(loc locp))
-(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
- "Locative data type. See `locf' and `ref'."
- (reader nil :type function)
- (writer nil :type function))
-
-(export 'locf)
-(defmacro locf (place &environment env)
- "Slightly cheesy locatives.
-
- (locf PLACE) returns an object which, using the `ref' function, can be
- used to read or set the value of PLACE. It's cheesy because it uses
- closures rather than actually taking the address of something. Also,
- unlike Zetalisp, we don't overload `car' to do our dirty work."
- (multiple-value-bind
- (valtmps valforms newtmps setform getform)
- (get-setf-expansion place env)
- `(let* (,@(mapcar #'list valtmps valforms))
- (make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
-
-(export 'ref)
-(declaim (inline ref (setf ref)))
-(defun ref (loc)
- "Fetch the value referred to by a locative."
- (funcall (loc-reader loc)))
-(defun (setf ref) (new loc)
- "Store a new value in the place referred to by a locative."
- (funcall (loc-writer loc) new))
-
-(export 'with-locatives)
-(defmacro with-locatives (locs &body body)
- "Evaluate BODY with implicit locatives.
-
- LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
- symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
- defaults to SYM. As an abbreviation for a common case, LOCS may be a
- symbol instead of a list.
-
- The BODY is evaluated in an environment where each SYM is a symbol macro
- which expands to (ref LOC-EXPR) -- or, in fact, something similar which
- doesn't break if LOC-EXPR has side-effects. Thus, references, including
- `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
- Useful for covering over where something uses a locative."
- (setf locs (mapcar (lambda (item)
- (cond ((atom item) (list item item))
- ((null (cdr item)) (list (car item) (car item)))
- (t item)))
- (if (listp locs) locs (list locs))))
- (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
- (ll (mapcar #'cadr locs))
- (ss (mapcar #'car locs)))
- `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
- (symbol-macrolet (,@(mapcar (lambda (sym tmp)
- `(,sym (ref ,tmp))) ss tt))
- ,@body))))
-
-;;;--------------------------------------------------------------------------
;;; Standard error-reporting functions.
(export 'moan)
;;;--------------------------------------------------------------------------
;;; Utilities.
+(export 'combine-parser-failures)
(defun combine-parser-failures (failures)
"Combine the failure indicators listed in FAILURES.
body)))
;;;--------------------------------------------------------------------------
+;;; Locatives.
+
+(export '(loc locp))
+(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
+ "Locative data type. See `locf' and `ref'."
+ (reader nil :type function)
+ (writer nil :type function))
+
+(export 'locf)
+(defmacro locf (place &environment env)
+ "Slightly cheesy locatives.
+
+ (locf PLACE) returns an object which, using the `ref' function, can be
+ used to read or set the value of PLACE. It's cheesy because it uses
+ closures rather than actually taking the address of something. Also,
+ unlike Zetalisp, we don't overload `car' to do our dirty work."
+ (multiple-value-bind
+ (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list valtmps valforms))
+ (make-loc (lambda () ,getform)
+ (lambda (,@newtmps) ,setform)))))
+
+(export 'ref)
+(declaim (inline ref (setf ref)))
+(defun ref (loc)
+ "Fetch the value referred to by a locative."
+ (funcall (loc-reader loc)))
+(defun (setf ref) (new loc)
+ "Store a new value in the place referred to by a locative."
+ (funcall (loc-writer loc) new))
+
+(export 'with-locatives)
+(defmacro with-locatives (locs &body body)
+ "Evaluate BODY with implicit locatives.
+
+ LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
+ symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
+ defaults to SYM. As an abbreviation for a common case, LOCS may be a
+ symbol instead of a list.
+
+ The BODY is evaluated in an environment where each SYM is a symbol macro
+ which expands to (ref LOC-EXPR) -- or, in fact, something similar which
+ doesn't break if LOC-EXPR has side-effects. Thus, references, including
+ `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
+ Useful for covering over where something uses a locative."
+ (setf locs (mapcar (lambda (item)
+ (cond ((atom item) (list item item))
+ ((null (cdr item)) (list (car item) (car item)))
+ (t item)))
+ (if (listp locs) locs (list locs))))
+ (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
+ (ll (mapcar #'cadr locs))
+ (ss (mapcar #'car locs)))
+ `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
+ (symbol-macrolet (,@(mapcar (lambda (sym tmp)
+ `(,sym (ref ,tmp))) ss tt))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
;;; Anaphorics.
(export 'it)
`((defun (setf ,from) (value object)
(setf (,to object) value))))))
-(export 'define-on-demand-slot)
-(defmacro define-on-demand-slot (class slot (instance) &body body)
- "Defines a slot which computes its initial value on demand.
-
- Sets up the named SLOT of CLASS to establish its value as the implicit
- progn BODY, by defining an appropriate method on `slot-unbound'."
- (with-gensyms (classvar slotvar)
- `(defmethod slot-unbound
- (,classvar (,instance ,class) (,slotvar (eql ',slot)))
- (declare (ignore ,classvar))
- (setf (slot-value ,instance ',slot) (progn ,@body)))))
-
;;;--------------------------------------------------------------------------
;;; CLOS hacking.
(setf (slot-value ,instance ,slot)
(progn ,@value)))))
+(export 'define-on-demand-slot)
+(defmacro define-on-demand-slot (class slot (instance) &body body)
+ "Defines a slot which computes its initial value on demand.
+
+ Sets up the named SLOT of CLASS to establish its value as the implicit
+ progn BODY, by defining an appropriate method on `slot-unbound'."
+ (with-gensyms (classvar slotvar)
+ `(defmethod slot-unbound
+ (,classvar (,instance ,class) (,slotvar (eql ',slot)))
+ (declare (ignore ,classvar))
+ (setf (slot-value ,instance ',slot) (progn ,@body)))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff