Commit 34ae7a05 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Corrections to satisfy sbcl.

parent a45fb3a8
......@@ -731,6 +731,7 @@ when it's the case, end-of-file is detected upon reading on an empty pipe.")
(slot-value (pipe-output-stream pipe) 'open) t))
(gate-signal (not-empty pipe)))
(defgeneric close-pipe (pipe))
(defmethod close-pipe ((pipe generic-pipe))
(with-lock-held ((lock pipe))
(setf (slot-value (pipe-output-stream pipe) 'open) nil))
......
......@@ -46,12 +46,12 @@
"ELEMENT-CHILD"
"STRING-SINGLE-CHILD-P"
"CHILD-TAGGED" "CHILDREN-TAGGED" "GRANDCHILDREN-TAGGED"
"CHILD-VALUED" "CHILDREN-VALUED" "GRANDCHILDREN-VALUED"
"CHILD-TAGGED-AND-VALUED" "CHILDREN-TAGGED-AND-VALUED" "GRANDCHILDREN-TAGGED-AND-VALUED"
"CHILD-TAGGED" "CHILD-VALUED" "CHILD-TAGGED-AND-VALUED"
"CHILDREN-TAGGED" "CHILDREN-VALUED" "CHILDREN-TAGGED-AND-VALUED"
"GRANDCHILD-TAGGED" "GRANDCHILD-VALUED" "GRANDCHILD-TAGGED-AND-VALUED"
"GRANDCHILDREN-TAGGED" "GRANDCHILDREN-VALUED" "GRANDCHILDREN-TAGGED-AND-VALUED"
"ELEMENT-AT-PATH"
"VALUE-TO-BOOLEAN")
(:documentation "
......@@ -206,13 +206,25 @@ In addition to normal elements, there are sgml directives
(defgeneric children-tagged (element tag))
(defgeneric grandchildren-tagged (element tag))
(defgeneric grandchild-tagged (element tag)
(:method (element tag)
(first (grandchildren-tagged element tag))))
(defgeneric child-valued (element attribute value))
(defgeneric children-valued (element attribute value))
(defgeneric grandchildren-valued (element attribute value))
(defgeneric grandchild-valued (element attribute value)
(:method (element attribute value)
(first (grandchildren-valued element attribute value))))
(defgeneric child-tagged-and-valued (element tag attribute value))
(defgeneric children-tagged-and-valued (element tag attribute value))
(defgeneric grandchild-tagged-and-valued (element tag attribute value))
(defgeneric grandchildren-tagged-and-valued (element tag attribute value))
(defgeneric grandchild-tagged-and-valued (element tag attribute value)
(:method (element tag attribute value)
(first (grandchildren-tagged-and-valued element tag attribute value))))
(defgeneric element-at-path (element tag-path))
......
This diff is collapsed.
......@@ -69,19 +69,9 @@
;; Macros are taken from clisp sources, and adapted.
(eval-when (:execute :compile-toplevel :load-toplevel)
(defun parse-body (body)
(values (extract-body body)
(let ((decls '()))
(maphash
(lambda (k v)
(setf decls (nconc (mapcar (lambda (d) (cons k v)) v) decls)))
(declarations-hash-table (extract-declarations body)))
decls))))
(defmacro with-open-file ((stream &rest options) &body body)
(multiple-value-bind (body-rest declarations) (parse-body body)
(multiple-value-bind (body-rest declarations) (parse-body :locally body)
`(let ((,stream (open ,@options)))
(declare (read-only ,stream) ,@declarations)
(unwind-protect
......@@ -91,7 +81,7 @@
(defmacro with-open-stream ((var stream) &body body)
(multiple-value-bind (body-rest declarations) (parse-body body)
(multiple-value-bind (body-rest declarations) (parse-body :locally body)
`(let ((,var ,stream))
(declare (read-only ,var) ,@declarations)
(unwind-protect
......@@ -102,7 +92,7 @@
(defmacro with-input-from-string ((var string &key (index nil sindex)
(start '0 sstart) (end 'nil send))
&body body)
(multiple-value-bind (body-rest declarations) (parse-body body)
(multiple-value-bind (body-rest declarations) (parse-body :loally body)
`(let ((,var (make-string-input-stream
,string
,@(if (or sstart send)
......@@ -118,7 +108,7 @@
(defmacro with-output-to-string ((var &optional (string nil)
&key (element-type ''character))
&body body)
(multiple-value-bind (body-rest declarations) (parse-body body)
(multiple-value-bind (body-rest declarations) (parse-body :locally body)
(if string
(let ((ignored-var (gensym)))
`(let ((,var (make-instance 'string-output-stream :string ,string))
......
......@@ -247,39 +247,45 @@ DO: Specifies the name and parameter list of methods.
(defun ,name ,arguments
,@(when documentation (list documentation))
,@(when stream-designator
`((setf ,stream-name (stream-designator
,stream-name
,(if (listp stream-designator)
(ecase (second stream-designator)
((:input) '*standard-input*)
((:output) '*standard-output*))
'*standard-input*)))))
`((setf ,stream-name (stream-designator
,stream-name
,(if (listp stream-designator)
(ecase (second stream-designator)
((:input) '*standard-input*)
((:output) '*standard-output*))
'*standard-input*)))))
,(if (lambda-list-rest-p lambda-list)
`(apply (function ,m-name) ,@(make-argument-list lambda-list))
`(,m-name ,@(butlast (make-argument-list lambda-list)))))
,@(when cl-forward
`((defmethod ,m-name
,(make-method-lambda-list lambda-list stream-name 'cl-stream)
,(let ((arguments (mapcar
(lambda (arg)
(if (eq arg stream-name)
`(cl-stream-stream ,stream-name)
arg))
(make-argument-list lambda-list))))
(if (lambda-list-rest-p lambda-list)
`(apply (function ,cl-name) ,@arguments)
`(,cl-name ,@(butlast arguments)))))
;; We don't want to allow access to CL:STREAM from a sandbox.
;; (defmethod ,m-name
;; ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
;; ,(let ((arguments (make-argument-list lambda-list)))
;; (if (lambda-list-rest-p lambda-list)
;; `(apply (function ,cl-name) ,@arguments)
;; `(,cl-name ,@(butlast arguments)))))
))
;; TODO: review the generation of generic function lambda list:
(let ((method-lambda-list (make-method-lambda-list lambda-list stream-name 'cl-stream)))
`((defgeneric ,m-name ,(mapcar (lambda (parameter)
(if (listp parameter)
(first parameter)
parameter))
method-lambda-list))
(defmethod ,m-name ,method-lambda-list
,(let ((arguments (mapcar
(lambda (arg)
(if (eq arg stream-name)
`(cl-stream-stream ,stream-name)
arg))
(make-argument-list lambda-list))))
(if (lambda-list-rest-p lambda-list)
`(apply (function ,cl-name) ,@arguments)
`(,cl-name ,@(butlast arguments)))))
;; We don't want to allow access to CL:STREAM from a sandbox.
;; (defmethod ,m-name
;; ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
;; ,(let ((arguments (make-argument-list lambda-list)))
;; (if (lambda-list-rest-p lambda-list)
;; `(apply (function ,cl-name) ,@arguments)
;; `(,cl-name ,@(butlast arguments)))))
)))
,@(when check-stream-type
`((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
(signal-type-error ,stream-name ',check-stream-type))))
`((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
(signal-type-error ,stream-name ',check-stream-type))))
,@(mapcar
(lambda (method)
(when (and (listp method) (eq :method (car method)))
......@@ -348,7 +354,6 @@ DO: Expands to a bunch of defmethod forms, with the parameter
eof-value))
(define-forward read-byte (stream &optional (eof-error-p t) (eof-value nil))
(declare (stream-argument stream)
(check-stream-type stream)
......
......@@ -64,6 +64,7 @@
())
(defgeneric print-object-fields (self stream))
(defmethod print-object-fields ((self file-stream) stream)
(call-next-method)
(format stream " :PATHNAME ~S :POSITION ~A"
......
......@@ -32,7 +32,7 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "COM.INFORMATIMAGO.LANGUAGES.C11.PARSER")
(declaim (declaration stepper))
(defclass pre-scanned-scanner (buffered-scanner)
((tokens :initform '() :initarg :tokens :accessor pre-scanned-tokens)
......@@ -1031,6 +1031,8 @@ NOTE: if the top-of-stack is :typedef then pop it as well as the specifiers.
(defun check-constant-expression (expression)
(declare (ignore expression))
#|TODO|#
(values))
(defun check-unary (expression)
......
......@@ -61,7 +61,8 @@
(defvar *line-width* 80)
(defmacro with-doc-output (target &body body)
`(let ((*standard-output* (or (documentation-file ,target) t))
`(let ((*standard-output* (or (documentation-file ,target)
*standard-output*))
;; TODO: add a line-width slot to text-documentation.
(*line-width* *print-right-margin*))
,@body))
......
......@@ -52,8 +52,8 @@
"GRAMMAR-ALL-TERMINALS" "GRAMMAR-ALL-NON-TERMINALS"
"GRAMMAR-SKIP-SPACES"
"FIND-RULE" "TERMINALP" "NON-TERMINAL-P"
"FIRST-SET" "FOLLOW-SET" "NULLABLEP"
"FIND-RHSES" "FIND-RHS" "TERMINALP" "NON-TERMINAL-P"
"FIRSTS-SET" "FOLLOW-SET" "NULLABLEP"
"SENTENCE-FIRST-SET"
"CLEAN-RULES"
......
......@@ -190,12 +190,14 @@
(defparameter *lex* 0)
(defun first-rhs (grammar item)
(first-set grammar item))
(firsts-set grammar item))
(defgeneric gen-parsing-statement (target grammar item))
(defmethod gen-parsing-statement ((target (eql :basic)) grammar item)
(labels ((es-first-set (extended-sentence)
(if (atom extended-sentence)
(first-set grammar extended-sentence)
(firsts-set grammar extended-sentence)
(ecase (car extended-sentence)
((seq) (loop
:with all-firsts = '()
......@@ -278,13 +280,12 @@
(emit "ENDIF")))))
(gen (second item))))))))
(defmethod generate-nt-parser ((target (eql :basic)) grammar non-terminal &key (trace nil))
(defmethod generate-non-terminal-parser-function ((target (eql :basic)) grammar non-terminal &key (trace nil))
(let ((fname (gen-parse-function-name target grammar non-terminal)))
`(progn
(emit "SUB ~A" ',fname)
,@(when trace `((emit "PRINT \"> ~A\"" ',(symbol-name fname))))
,(gen-parsing-statement target grammar (find-rule grammar non-terminal))
,(gen-parsing-statement target grammar (find-rhs grammar non-terminal))
,@(when trace `((emit "PRINT \"< ~A\"" ',(symbol-name fname))))
(emit "ENDSUB"))))
......
......@@ -142,6 +142,7 @@ Use (GRAMMAR-NAMED name) to look up a grammar.")
(setf (gethash (grammar-name grammar) *grammars*) grammar))
#-sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (documentation 'seq t) "
......@@ -202,8 +203,6 @@ Returns parsed term.
"))
(defgeneric generate-boilerplate (target-language grammar &key trace)
(:documentation "Generate the boilerplate code needed by the scanner and parser.
......@@ -904,6 +903,12 @@ RETURN: the new production set; the new non-terminal set
;;; actions := ( <form>* ) .
;;; ε is represented as (seq () ('nil))
(defgeneric add-production (grammar non-terminal rhs))
(defgeneric remove-production (grammar non-terminal rhs))
(defgeneric eliminate-left-recursion (grammar))
(defgeneric eliminate-left-recursive-p (grammar))
(defmethod add-production ((grammar grammar) non-terminal rhs)
(assert (not (terminalp grammar non-terminal)))
(push (list non-terminal rhs) (grammar-rules grammar))
......@@ -945,7 +950,6 @@ RETURN: the new production set; the new non-terminal set
:finally (compute-all-non-terminals grammar))
grammar)
(defmethod eliminate-left-recursive-p ((grammar normalized-grammar))
(error "Not implemented yet."))
......@@ -961,6 +965,8 @@ RETURN: the new production set; the new non-terminal set
(defgeneric gen-scanner-class-name (target grammar))
(defgeneric gen-parse-function-name (target grammar non-terminal))
(defgeneric generate-parsing-expression (target grammar non-terminal item))
(defgeneric generate-parsing-sequence (target grammar non-terminal rhs))
(defgeneric generate-non-terminal-parsing-expression (target grammar non-terminal))
;;;------------------------------------------------------------
;;; Scanner generator
......@@ -1286,7 +1292,6 @@ should be bound for actions.
(generate-parsing-sequence target grammar non-terminal rhs))
(t (error "Invalid item ~S found in rule for ~S" rhs non-terminal))))
(defmethod generate-non-terminal-parsing-expression ((target (eql :lisp)) (grammar normalized-grammar) non-terminal)
(let* ((rhses (find-rhses grammar non-terminal))
;; (firsts (firsts-set grammar non-terminal))
......
......@@ -32,11 +32,6 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (find-package "UIOP")
(push :uiop *features*)
(setf *features* (remove :uiop *features*))))
#+mocl
(asdf:defsystem "com.informatimago.tools.try-systems"
:description "Tries to compile systems like in quicklisp validation compilations."
......@@ -70,9 +65,11 @@ by forking an sbcl instance per system.
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.tools.source"
"com.informatimago.tools.script"
"split-sequence")
:components ((:file "dummy-uiop")
(:file "try-systems" :depends-on ("dummy-uiop")))
"split-sequence"
"uiop")
:components (;; (:file "dummy-uiop")
(:file "try-systems" :depends-on (;; "dummy-uiop"
)))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment