[sod] / src / module-parse.lisp

;;; -*-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.

(defun parse-class-body (scaner pset name supers)
  ;; class-body ::= `{' class-item* `}'
  (with-parser-context (token-scanner-context :scanner scanner)
    (make-class-type name)
    (let* ((class (make-sod-class name (mapcat #'find-sod-class supers)
				  pset scanner))
	   (nick (sod-class-nickname class)))

      (labels ((parse-maybe-dotted-declarator (base-type)
		 ;; Parse a declarator or dotted-declarator, i.e., one whose
		 ;; centre is
		 ;;
		 ;; maybe-dotted-identifier ::= [id `.'] id
		 ;;
		 ;; A plain identifier is returned as a string, as usual; a
		 ;; dotted identifier is returned as a cons cell of the two
		 ;; names.
		 (parse-declarator
		  scanner base-type
		  :centre (parser ()
			    (seq ((name-a :id)
				  (name-b (? (seq (#\. (id :id)) id))))
			      (if name-b (cons name-a name-b)
				  name-a)))))

	       ;; class-item ::= [property-set] raw-class-item
	       ;;

	       (parse-message-item (sub-pset type name)
		 ;; message-item ::=
		 ;;	declspec+ declarator -!- (method-body | `;')
		 (make-sod-message class name type sub-pset scanner)
		 (parse (or #\; (parse-method-item nil type nick name))))

	       (parse-method-item (sub-pset type sub-nick name)
		 ;; method-item ::=
		 ;;	declspec+ dotted-declarator -!- method-body
		 ;;
		 ;; method-body ::= `{' c-fragment `}' | `extern' `;'
		 (parse (seq ((body (or (seq ("extern" #\;) nil)
					(parse-delimited-fragment
					 scanner #\{ #\}))))
			  (make-sod-method class sub-nick name type
					   body sub-pset scanner))))

	       (parse-initializer ()
		 ;; initializer ::= `=' c-fragment | `=' `{' c-fragment `}'
		 ;;
		 ;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a
		 ;; `sod-initializer' constructor.
		 (parse (or (peek (seq (#\= (frag (parse-delimited-fragment
						   scanner #\{ #\})))
				    (cons :compound frag)))
			    (seq ((frag (parse-delimited-fragment
					 scanner #\= '(#\; #\,)
					 :keep-end t)))
			      (cons :simple frag)))))

	       (parse-slot-item (sub-pset base-type type name)
		 ;; slot-item ::=
		 ;;	declspec+ declarator -!- [initializer]
		 ;;		[`,' init-declarator-list] `;'
		 ;;
		 ;; init-declarator-list ::=
		 ;;	declarator [initializer] [`,' init-declarator-list]
		 (parse (and (seq ((init (? (parse-initializer))))
			       (make-sod-slot class name type
					      sub-pset scanner)
			       (when init
				 (make-sod-instance-initializer
				  class nick name (car init) (cdr init)
				  nil scanner)))
			     (skip-many ()
			       (seq (#\,
				     (ds (parse-declarator scanner
							   base-type))
				     (init (? (parse-initializer))))
				 (make-sod-slot class (cdr ds) (car ds)
						sub-pset scanner)
				 (when init
				   (make-sod-instance-initializer
				    class nick (cdr ds)
				    (car init) (cdr init)
				    nil scanner))))
			     #\;)))

	       (parse-initializer-item (sub-pset constructor)
		 ;; initializer-item ::=
		 ;;	[`class'] -!- slot-initializer-list `;'
		 ;;
		 ;; slot-initializer ::= id `.' id initializer
		 (parse (and (skip-many ()
			       (seq ((name-a :id) #\. (name-b :id)
				     (init (parse-initializer)))
				 (funcall constructor class
					  name-a name-b
					  (car init) (cdr init)
					  sub-pset scanner))
			       #\,)
			     #\;)))

	       (class-item-dispatch (sub-pset base-type type name)
		 ;; Logically part of `parse-raw-class-item', but the
		 ;; indentation was getting crazy.  We're currently at
		 ;;
		 ;; raw-class-item ::=
		 ;;	declspec+ (declarator | dotted-declarator) -!- ...
		 ;;   | other-items
		 ;;
		 ;; If the declarator is dotted then this must be a method
		 ;; definition; otherwise it might be a message or slot.
		 (cond ((not (typep type 'c-function-type))
			(when (consp name)
			  (cerror*-with-location
			   scanner
			   "Method declarations must have function type.")
			  (setf name (cdr name)))
			(parse-slot-item sub-pset base-type type name))
		       ((consp name)
			(parse-method-item sub-pset type
					   (car name) (cdr name)))
		       (t
			(parse-message-item sub-pset type name))))

	       (parse-raw-class-item (sub-pset)
		 ;; raw-class-item ::=
		 ;;	message-item
		 ;;   | method-item
		 ;;   | slot-item
		 ;;   | initializer-item
		 ;;
		 ;; Most of the above begin with declspecs and a declarator
		 ;; (which might be dotted).  So we parse that here and
		 ;; dispatch based on what we find.
		 (parse (or (peek
			     (seq ((ds (parse-c-type scanner))
				   (dc (parse-maybe-dotted-declarator ds))
				   (result (class-item-dispatch sub-pset
								ds
								(car dc)
								(cdr dc))))
			       result))
			    (and "class"
				 (parse-initializer-item
				  sub-pset
				  #'make-sod-class-initializer))
			    (parse-initializer-item
			     sub-pset
			     #'make-sod-instance-initializer)))))

	(parse (and #\{
		    (skip-many ()
		      (seq ((sub-pset (? (parse-property-set)))
			    (nil (parse-raw-class-item sub-pset)))))
		    #\}))))))

(define-pluggable-parser module class (scanner)
  ;; `class' id [`:' id-list] class-body
  ;; `class' id `;'

  (with-parser-context (token-scanner-context :scanner scanner)
    (parse (seq ("class"
		 (name :id)
		 (nil (or (seq (#\;)
			    (make-class-type name))
			  (seq ((supers (? (seq (#\: (ids (list () :id #\,)))
					     ids)))
				(nil (parse-class-body
				      scanner
				      pset name supers)))))))))))


    (parse (seq ("class"
		 (name :id)
		 (supers (? (seq (#\: (supers (list (:min 1) :id #\,)))
				 supers)))
		 #\{
		 

;;;----- That's all, folks --------------------------------------------------
Commit	Line	Data
bf090e02 MW	1	;;; --lisp--
	2	;;;
	3	;;; Top-level parser for module syntax
	4	;;;
	5	;;; (c) 2010 Straylight/Edgeware
	6	;;;
	7
	8	;;;----- Licensing notice ---------------------------------------------------
	9	;;;
	10	;;; This file is part of the Sensble Object Design, an object system for C.
	11	;;;
	12	;;; SOD is free software; you can redistribute it and/or modify
	13	;;; it under the terms of the GNU General Public License as published by
	14	;;; the Free Software Foundation; either version 2 of the License, or
	15	;;; (at your option) any later version.
	16	;;;
	17	;;; SOD is distributed in the hope that it will be useful,
	18	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;;; GNU General Public License for more details.
	21	;;;
	22	;;; You should have received a copy of the GNU General Public License
	23	;;; along with SOD; if not, write to the Free Software Foundation,
	24	;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
	25
	26	(in-package #:sod)
	27
	28	;;;--------------------------------------------------------------------------
	29	;;; Toplevel syntax.
	30
	31	(export 'module)
	32
	33	;;; Type names.
	34
	35	(define-pluggable-parser module typename (scanner)
	36	;; `typename' ID ( `,' ID )* `;'
	37
	38	(with-parser-context (token-scanner-context :scanner scanner)
	39	(parse (and "typename"
	40	(skip-many (:min 1)
	41	(seq ((id :id))
	42	(if (gethash id module-type-map)
	43	(cerror* "Type `~A' already defined" id)
	44	(add-to-module module
	45	(make-instance 'type-item
	46	:name id))))
	47	#\,)
	48	#\;))))
	49
	50	;;; Fragments.
	51
	52	(define-pluggable-parser module code (scanner)
	53	;; `code' ID `:' ID [ CONSTRAINTS ] `{' C-FRAGMENT `}'
	54
	55	(with-parser-context (token-scanner-context :scanner scanner)
	56	(parse (seq ("code"
	57	(reason :id)
	58	#\:
	59	(name :id)
	60	(constraints (? (seq (#\[
	61	(constraints (list (:min 1)
	62	(list (:min 1) :id)
	63	#\,))
	64	#\])
65	constraints)))
66	(fragment (parse-delimited-fragment scanner #\{ #\})))
67	(add-to-module module (make-instance 'code-fragment-item
68	:fragment fragment
69	:constraints constraints
70	:reason reason
71	:name name))))))
72
73	;;; External files.
74
75	(defun read-module (pathname &key (truename (truename pathname)) location)
76	"Parse the file at PATHNAME as a module, returning it.
77
78	This is the main entry point for parsing module files. You may well know
79	the file's TRUENAME already (e.g., because `probe-file' dropped it into
80	your lap) so you can avoid repeating the search by providing it.
81
82	The LOCATION is the thing which wanted the module imported -- usually a
83	`file-location' object, though it might be anything other than `t' which
84	can be printed in the event of circular imports."
85
86	(define-module (pathname :location location :truename truename)
87	(with-open-file (f-stream pathname :direction :input)
88	(let* ((readtable (copy-readtable))
89	(char-scanner (make-instance 'charbuf-scanner
90	:stream f-stream))
91	(scanner (make-instance 'sod-token-scanner
92	:char-scanner char-scanner)))
93	(with-default-error-location (scanner)
94	(with-parser-context (token-scanner-context :scanner scanner)
95	(parse (skip-many () (plug module scanner)))))))))
96
97	(define-pluggable-parser module test (scanner)
98	;; `demo' STRING `;'
99
100	(with-parser-context (token-scanner-context :scanner scanner)
101	(parse (seq ("demo" (string :string) #\;)
102	(format t ";; DEMO ~S~%" string)))))
103
104	(define-pluggable-parser module file (scanner)
105	;; `import' STRING `;'
106	;; `load' STRING `;'
107
108	(flet ((common (name type what thunk)
109	(find-file scanner
110	(merge-pathnames name
111	(make-pathname :type type
112	:case :common))
113	what
114	thunk)))
115	(with-parser-context (token-scanner-context :scanner scanner)
116	(parse (or (seq ("import" (name :string) #\;)
117	(common name "SOD" "module"
118	(lambda (path true)
119	(handler-case
120	(let ((module (read-module path
121	:truename true)))
122	(when module
123	(module-import module)
124	(pushnew module
125	(module-dependencies
126	module))))
127	(file-error (error)
128	(cerror* "Error reading module ~S: ~A"
129	path error))))))
130	(seq ("load" (name :string) #\;)
131	(common name "LISP" "Lisp file"
132	(lambda (path true)
133	(handler-case
134	(load true :verbose nil :print nil)
135	(error (error)
136	(cerror* "Error loading Lisp file ~S: ~A"
137	path error)))))))))))
138
139	;;; Lisp escape.
140
141	(define-pluggable-parser module lisp (scanner)
142	;; `lisp' s-expression `;'
143
144	(with-parser-context (token-scanner-context :scanner scanner)
145	(parse (seq ((sexp (if (and (eql (token-type scanner) :id)
146	(string= (token-value scanner) "lisp"))
147	(let* ((stream (make-scanner-stream scanner))
148	(sexp (read stream t)))
149	(scanner-step scanner)
150	(values sexp t t))
151	(values '((:id "lisp")) nil nil)))
152	#\;)
153	(eval sexp)))))
154
155	;;;--------------------------------------------------------------------------
156	;;; Class declarations.
157
c91b90c3 MW	158	(defun parse-class-body (scaner pset name supers)
	159	;; class-body ::= `{' class-item* `}'
	160	(with-parser-context (token-scanner-context :scanner scanner)
	161	(make-class-type name)
	162	(let* ((class (make-sod-class name (mapcat #'find-sod-class supers)
	163	pset scanner))
	164	(nick (sod-class-nickname class)))
	165
	166	(labels ((parse-maybe-dotted-declarator (base-type)
	167	;; Parse a declarator or dotted-declarator, i.e., one whose
	168	;; centre is
	169	;;
	170	;; maybe-dotted-identifier ::= [id `.'] id
	171	;;
	172	;; A plain identifier is returned as a string, as usual; a
	173	;; dotted identifier is returned as a cons cell of the two
	174	;; names.
	175	(parse-declarator
	176	scanner base-type
	177	:centre (parser ()
	178	(seq ((name-a :id)
	179	(name-b (? (seq (#\. (id :id)) id))))
	180	(if name-b (cons name-a name-b)
	181	name-a)))))
	182
	183	;; class-item ::= [property-set] raw-class-item
	184	;;
	185
	186	(parse-message-item (sub-pset type name)
	187	;; message-item ::=
	188	;; declspec+ declarator -!- (method-body \| `;')
	189	(make-sod-message class name type sub-pset scanner)
	190	(parse (or #\; (parse-method-item nil type nick name))))
	191
	192	(parse-method-item (sub-pset type sub-nick name)
	193	;; method-item ::=
	194	;; declspec+ dotted-declarator -!- method-body
	195	;;
	196	;; method-body ::= `{' c-fragment `}' \| `extern' `;'
	197	(parse (seq ((body (or (seq ("extern" #\;) nil)
	198	(parse-delimited-fragment
	199	scanner #\{ #\}))))
	200	(make-sod-method class sub-nick name type
	201	body sub-pset scanner))))
	202
	203	(parse-initializer ()
	204	;; initializer ::= `=' c-fragment \| `=' `{' c-fragment `}'
	205	;;
	206	;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a
	207	;; `sod-initializer' constructor.
	208	(parse (or (peek (seq (#\= (frag (parse-delimited-fragment
	209	scanner #\{ #\})))
	210	(cons :compound frag)))
	211	(seq ((frag (parse-delimited-fragment
	212	scanner #\= '(#\; #\,)
	213	:keep-end t)))
	214	(cons :simple frag)))))
	215
	216	(parse-slot-item (sub-pset base-type type name)
	217	;; slot-item ::=
	218	;; declspec+ declarator -!- [initializer]
	219	;; [`,' init-declarator-list] `;'
	220	;;
	221	;; init-declarator-list ::=
222	;; declarator [initializer] [`,' init-declarator-list]
223	(parse (and (seq ((init (? (parse-initializer))))
224	(make-sod-slot class name type
225	sub-pset scanner)
226	(when init
227	(make-sod-instance-initializer
228	class nick name (car init) (cdr init)
229	nil scanner)))
230	(skip-many ()
231	(seq (#\,
232	(ds (parse-declarator scanner
233	base-type))
234	(init (? (parse-initializer))))
235	(make-sod-slot class (cdr ds) (car ds)
236	sub-pset scanner)
237	(when init
238	(make-sod-instance-initializer
239	class nick (cdr ds)
240	(car init) (cdr init)
241	nil scanner))))
242	#\;)))
243
244	(parse-initializer-item (sub-pset constructor)
245	;; initializer-item ::=
246	;; [`class'] -!- slot-initializer-list `;'
247	;;
248	;; slot-initializer ::= id `.' id initializer
249	(parse (and (skip-many ()
250	(seq ((name-a :id) #\. (name-b :id)
251	(init (parse-initializer)))
252	(funcall constructor class
253	name-a name-b
254	(car init) (cdr init)
255	sub-pset scanner))
256	#\,)
257	#\;)))
258
259	(class-item-dispatch (sub-pset base-type type name)
260	;; Logically part of `parse-raw-class-item', but the
261	;; indentation was getting crazy. We're currently at
262	;;
263	;; raw-class-item ::=
264	;; declspec+ (declarator \| dotted-declarator) -!- ...
265	;; \| other-items
266	;;
267	;; If the declarator is dotted then this must be a method
268	;; definition; otherwise it might be a message or slot.
269	(cond ((not (typep type 'c-function-type))
270	(when (consp name)
271	(cerror*-with-location
272	scanner
273	"Method declarations must have function type.")
274	(setf name (cdr name)))
275	(parse-slot-item sub-pset base-type type name))
276	((consp name)
277	(parse-method-item sub-pset type
278	(car name) (cdr name)))
279	(t
280	(parse-message-item sub-pset type name))))
281
282	(parse-raw-class-item (sub-pset)
283	;; raw-class-item ::=
284	;; message-item
285	;; \| method-item
286	;; \| slot-item
287	;; \| initializer-item
288	;;
289	;; Most of the above begin with declspecs and a declarator
290	;; (which might be dotted). So we parse that here and
291	;; dispatch based on what we find.
292	(parse (or (peek
293	(seq ((ds (parse-c-type scanner))
294	(dc (parse-maybe-dotted-declarator ds))
295	(result (class-item-dispatch sub-pset
296	ds
297	(car dc)
298	(cdr dc))))
299	result))
300	(and "class"
301	(parse-initializer-item
302	sub-pset
303	#'make-sod-class-initializer))
304	(parse-initializer-item
305	sub-pset
306	#'make-sod-instance-initializer)))))
307
308	(parse (and #\{
309	(skip-many ()
310	(seq ((sub-pset (? (parse-property-set)))
311	(nil (parse-raw-class-item sub-pset)))))
312	#\}))))))
313
bf090e02	314	(define-pluggable-parser module class (scanner)
c91b90c3 MW	315	;; `class' id [`:' id-list] class-body
c91b90c3 MW	316	;; `class' id `;'
bf090e02 MW	317
bf090e02 MW	318	(with-parser-context (token-scanner-context :scanner scanner)
c91b90c3 MW	319	(parse (seq ("class"
	320	(name :id)
	321	(nil (or (seq (#\;)
	322	(make-class-type name))
	323	(seq ((supers (? (seq (#\: (ids (list () :id #\,)))
	324	ids)))
	325	(nil (parse-class-body
	326	scanner
	327	pset name supers)))))))))))
	328
	329
	330
	331
bf090e02 MW	332	(parse (seq ("class"
	333	(name :id)
	334	(supers (? (seq (#\: (supers (list (:min 1) :id #\,)))
	335	supers)))
	336	#\{
	337
	338
	339	;;;----- That's all, folks --------------------------------------------------