From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 30 Aug 2015 09:58:38 +0000 (+0100)
Subject: Merge branch 'master' into doc
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/bb80145308ea388d7c6ed5336c061340e78f66e8?hp=e417fab55d827640e10b832b85978847a1bfe5d5

Merge branch 'master' into doc

* master:
  src/utilities.lisp, src/optparse.lisp: Move locatives to `utilities'.
  src/c-types-proto.lisp: Fix docstring.
  src/parser/parser-proto.lisp: Export `combine-parser-failures'.
  src/utilities.lisp: Move `define-on-demand-slot' to the right section.
  src/codegen-impl.lisp: Rename some `inst' slots.
  src/codegen-{proto,impl}.lisp: Make *temporary-index* be a module var.
  src/class-make-proto.lisp: Choose Lisp metaclass more cleverly.
  src/class-make-impl.lisp: Abstract out the guts of `guess-metaclass'.
  src/c-types-impl.lisp: Fix arg list in `c-function-type' instance init.
  src/lexer-bits.lisp: Delete crufty old file.
---

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 4a0f6e2..ed65110 100644
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -418,24 +418,30 @@
 (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.
 
diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp
index b9b61bf..edadd64 100644
--- a/src/c-types-proto.lisp
+++ b/src/c-types-proto.lisp
@@ -253,7 +253,7 @@
    "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)))
diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 878f813..29a30c1 100644
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -28,19 +28,23 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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.
@@ -66,7 +70,8 @@
   ;; 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)
diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp
index c04727c..8b024bd 100644
--- a/src/class-make-proto.lisp
+++ b/src/class-make-proto.lisp
@@ -45,8 +45,14 @@
 
   (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)
diff --git a/src/codegen-impl.lisp b/src/codegen-impl.lisp
index 170f4a8..d988b12 100644
--- a/src/codegen-impl.lisp
+++ b/src/codegen-impl.lisp
@@ -37,6 +37,16 @@
   ((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)
 
@@ -70,18 +80,18 @@
 ;; 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#))
diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 535839c..6b1f947 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -55,18 +55,6 @@
   (: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*))
diff --git a/src/lexer-bits.lisp b/src/lexer-bits.lisp
deleted file mode 100644
index b671164..0000000
--- a/src/lexer-bits.lisp
+++ /dev/null
@@ -1,98 +0,0 @@
-(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))))))
diff --git a/src/optparse.lisp b/src/optparse.lisp
index 70bb012..a2ac290 100644
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -113,66 +113,6 @@
   (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)
diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp
index d458e70..4bd1ae4 100644
--- a/src/parser/parser-proto.lisp
+++ b/src/parser/parser-proto.lisp
@@ -77,6 +77,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 
+(export 'combine-parser-failures)
 (defun combine-parser-failures (failures)
   "Combine the failure indicators listed in FAILURES.
 
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 98d314a..d1755da 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -195,6 +195,66 @@
 	    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)
@@ -713,18 +773,6 @@
 	    `((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.
 
@@ -749,4 +797,16 @@
        (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 --------------------------------------------------