Corrections to satisfy sbcl.

Pascal J. Bourguignon [2015-11-01 05:32]
Corrections to satisfy sbcl.
Filename
clext/pipe.lisp
common-lisp/html-base/ml-sexp.lisp
future/vfs/filenames.lisp
future/vfs/general.lisp
future/vfs/streams.lisp
future/vfs/vfs-file-stream.lisp
languages/c11/c11-parser.lisp
lispdoc/gentext.lisp
rdp/packages.lisp
rdp/rdp-basic-gen.lisp
rdp/rdp.lisp
tools/com.informatimago.tools.try-systems.asd
diff --git a/clext/pipe.lisp b/clext/pipe.lisp
index 315286b..baacbef 100644
--- a/clext/pipe.lisp
+++ b/clext/pipe.lisp
@@ -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))
diff --git a/common-lisp/html-base/ml-sexp.lisp b/common-lisp/html-base/ml-sexp.lisp
index 58dd31d..3b0904e 100644
--- a/common-lisp/html-base/ml-sexp.lisp
+++ b/common-lisp/html-base/ml-sexp.lisp
@@ -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))

diff --git a/future/vfs/filenames.lisp b/future/vfs/filenames.lisp
index f090662..7a30bc5 100644
--- a/future/vfs/filenames.lisp
+++ b/future/vfs/filenames.lisp
@@ -78,6 +78,7 @@
                          name
                          dummy2 type dummy3 version)
         (re-exec *logical-pathname-regexp* string :start start :end end)
+      (declare (ignore dummy0 dummy1 dummy2 dummy3))
       (if all
           (list (and host        (re-match-string string host))
                 (if relative :relative :absolute)
@@ -100,37 +101,37 @@
                          (t (parse-integer version :junk-allowed nil))))))
           (error "Syntax error parsing pathname ~S" string)))))

+(defun concat* (type list)
+  (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
+                          list :initial-value 0))
+         (result  (cond
+                    ((or (eq type 'string)
+                         (and (consp type) (eq 'string (first type))))
+                     (make-string totlen))
+                    ((or (eq type 'vector)
+                         (and (consp type) (eq 'vector (first type)))
+                         (eq type 'array)
+                         (and (consp type) (eq 'array (first type))))
+                     (make-array totlen))
+                    ((eq type 'list)
+                     (make-list totlen))
+                    (t (error "Invalid sequence type: ~S" type)))))
+    (loop
+      :for item :in list
+      :and start = 0 :then (+ start (length item))
+      :do (replace result item :start1 start)
+      :finally (return result))))

 (defun match-wild-word-p (item wild)
-  (flet ((concat (type list)
-           (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
-                                   list :initial-value 0))
-                  (result  (cond
-                             ((or (eq type 'string)
-                                  (and (consp type) (eq 'string (first type))))
-                              (make-string totlen))
-                             ((or (eq type 'vector)
-                                  (and (consp type) (eq 'vector (first type)))
-                                  (eq type 'array)
-                                  (and (consp type) (eq 'array (first type))))
-                              (make-array totlen))
-                             ((eq type 'list)
-                              (make-list totlen))
-                             (t (error "Invalid sequence type: ~S" type)))))
-             (loop
-               :for item :in list
-               :and start = 0 :then (+ start (length item))
-               :do (replace result item :start1 start)
-               :finally (return result)))))
-    (re-match
-     (concat 'string
-             (cons "^"
-                   (nconc
-                    (loop
-                      :for chunks :on (split-sequence #\* wild)
-                      :collect (car chunks) :when (cdr chunks) :collect ".*")
-                    (list "$"))))
-     item)))
+  (re-match
+   (concat* 'string
+            (cons "^"
+                  (nconc
+                   (loop
+                     :for chunks :on (split-sequence #\* wild)
+                     :collect (car chunks) :when (cdr chunks) :collect ".*")
+                   (list "$"))))
+   item))


 ;;;---------------------------------------------------------------------
@@ -187,6 +188,7 @@
 #+emacs (put 'define-pathname-attribute 'lisp-indent-function 1)
 (defmacro define-pathname-attribute (name &optional docstring)
   `(defun ,(intern (format nil "PATHNAME-~A" name)) (pathname &key (case :local))
+     (declare (ignore case))
      ,@(when docstring (list docstring))
      (,(intern (format nil "%PATHNAME-~A" name)) (pathname pathname))))

@@ -278,8 +280,8 @@ file). Implementations can define other special version symbols.")
                      ((eql :wild host)       'pathname)
                      ((logical-host-p host)  'logical-pathname)
                      (t                      'pathname))
-        :host host :directory (cons relative directory)
-        :name name :type type :version version)))
+                   :host host :directory (cons relative directory)
+                   :name name :type type :version version)))



@@ -325,6 +327,7 @@ file). Implementations can define other special version symbols.")


 (defun enough-namestring (pathname &optional defaults)
+  (declare (ignore pathname defaults))
   (error "enough-namestring not implemented yet"))


@@ -341,6 +344,7 @@ file). Implementations can define other special version symbols.")

 (defun make-pathname (&key host device directory name type version (case :local)
                         (defaults nil defaults-p))
+  (declare (ignore case))
   (cond ((stringp directory)  (setf directory (list :absolute directory)))
         ((eq :wild directory) (setf directory (list :absolute :wild-inferiors))))
   (let ((host (check-host (or host (if defaults-p
@@ -350,12 +354,12 @@ file). Implementations can define other special version symbols.")
                      ((eql :wild host)       'pathname)
                      ((logical-host-p host)  'logical-pathname)
                      (t                      'pathname))
-        :host        host
-        :device      (or device    (and defaults (pathname-device    defaults)))
-        :directory   (or directory (and defaults (pathname-directory defaults)))
-        :name        (or name      (and defaults (pathname-name      defaults)))
-        :type        (or type      (and defaults (pathname-type      defaults)))
-        :version     (or version   (and defaults (pathname-version   defaults))))))
+                   :host        host
+                   :device      (or device    (and defaults (pathname-device    defaults)))
+                   :directory   (or directory (and defaults (pathname-directory defaults)))
+                   :name        (or name      (and defaults (pathname-name      defaults)))
+                   :type        (or type      (and defaults (pathname-type      defaults)))
+                   :version     (or version   (and defaults (pathname-version   defaults))))))



@@ -400,7 +404,7 @@ RETURN: The logical pathname translations for the HOST.
                                             :name host
                                             :type "TRANSLATIONS"
                                             :version :newest)
-                             :if-does-not-exist nil)
+                        :if-does-not-exist nil)
         (if input
             (setf (logical-pathname-translations host) (read input nil nil))
             (error "No logical pathname translation file found for host ~S"
@@ -432,7 +436,7 @@ RETURN: The logical pathname translations for the HOST.
                                           (pathname-host thing :case :common)
                                           default-host))))
       (string
-       (if (string= thing "" :start start :end end)
+       (if (string= thing "" :start1 start :end1 end)
            (values (make-instance 'pathname :host nil :directory nil :name nil :type nil :version nil)
                    start)
            ;; TODO: implement junk-allowed
@@ -450,8 +454,8 @@ RETURN: The logical pathname translations for the HOST.
                                        ((eql :wild host)       'pathname)
                                        ((logical-host-p host)  'logical-pathname)
                                        (t                      'pathname))
-                          :host host :directory (cons relative directory)
-                          :name name :type type :version version)
+                                     :host host :directory (cons relative directory)
+                                     :name name :type type :version version)
                       (or end (length thing)))))
                  (values nil start))))))))

@@ -493,11 +497,12 @@ RETURN: The logical pathname translations for the HOST.
       (and (stringp item) (stringp wild) (string= item wild))))

 (defun match-directory-items-p (item wild)
-  (or (null item wild)
+  (or (null item)
+      (null wild)
       (if (eq (first wild) :wild-inferiors)
           (loop
             :for rest :on item
-            :thereis (match-directory-items-p rest (rest wild)))
+              :thereis (match-directory-items-p rest (rest wild)))
           (and (match-item-p (first item) (first wild) t)
                (match-directory-items-p (rest item) (rest wild))))))

@@ -546,6 +551,8 @@ RETURN: The logical pathname translations for the HOST.
   (assert-type source        '(or string pathname file-stream))
   (assert-type from-wildcard '(or string pathname file-stream))
   (assert-type to-wildcard   '(or string pathname file-stream))
+  (error "NOT IMPLEMENTED YET")
+  #-(and)
   (let ((source        (pathname-components (pathname source)))
         (from-wildcard (pathname-components (pathname from-wildcard)))
         (to-wildcard   (pathname-components (pathname to-wildcard))))
@@ -554,10 +561,7 @@ RETURN: The logical pathname translations for the HOST.
       :for s-compo :in source
       :for f-compo :in from-wildcard
       :for t-compo :in to-wildcard
-      :collect (if dirp
-
-
-                   ))))
+      :collect :to-be-done)))



@@ -571,7 +575,7 @@ RETURN: The logical pathname translations for the HOST.
       ""))

 (defun test ()
-  (let* ((source "CRACKBOOMHUH")
+  (let* (;; (source "CRACKBOOMHUH")
          (source "FOOZIMBAR")
          (from      (split-sequence #\* "FOO*BAR"))
          (to        (split-sequence #\* "Z(O)OM*ZOOM"))
@@ -593,16 +597,16 @@ RETURN: The logical pathname translations for the HOST.

 (defun delete-back (dir)
   (loop
-    :with changed = t
+    :with changed := t
     :while changed
     :do (loop
-          :for cur = dir :then (cdr cur)
-          :initially (setf changed nil)
+          :for cur := dir :then (cdr cur)
+            :initially (setf changed nil)
           :do (when (and (or (stringp (cadr cur)) (eq :wild (cadr cur)))
                          (eq :back (caddr cur)))
                 (setf (cdr cur) (cdddr cur)
-                      changed t)))
-    :finally (return dir)))
+                      changed t))))
+  dir)


 (defun merge-pathnames (pathname
diff --git a/future/vfs/general.lisp b/future/vfs/general.lisp
index 1407735..d01ae36 100644
--- a/future/vfs/general.lisp
+++ b/future/vfs/general.lisp
@@ -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))
diff --git a/future/vfs/streams.lisp b/future/vfs/streams.lisp
index 390ed24..06c0dea 100644
--- a/future/vfs/streams.lisp
+++ b/future/vfs/streams.lisp
@@ -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)
diff --git a/future/vfs/vfs-file-stream.lisp b/future/vfs/vfs-file-stream.lisp
index f26ff17..9169171 100644
--- a/future/vfs/vfs-file-stream.lisp
+++ b/future/vfs/vfs-file-stream.lisp
@@ -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"
diff --git a/languages/c11/c11-parser.lisp b/languages/c11/c11-parser.lisp
index 644410e..abb3caf 100644
--- a/languages/c11/c11-parser.lisp
+++ b/languages/c11/c11-parser.lisp
@@ -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)
diff --git a/lispdoc/gentext.lisp b/lispdoc/gentext.lisp
index 8cb272e..783dbab 100644
--- a/lispdoc/gentext.lisp
+++ b/lispdoc/gentext.lisp
@@ -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))
diff --git a/rdp/packages.lisp b/rdp/packages.lisp
index 6bf7e18..7fb2f93 100644
--- a/rdp/packages.lisp
+++ b/rdp/packages.lisp
@@ -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"
diff --git a/rdp/rdp-basic-gen.lisp b/rdp/rdp-basic-gen.lisp
index e82832e..b8b4a9f 100644
--- a/rdp/rdp-basic-gen.lisp
+++ b/rdp/rdp-basic-gen.lisp
@@ -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"))))

diff --git a/rdp/rdp.lisp b/rdp/rdp.lisp
index 793020b..74885bb 100644
--- a/rdp/rdp.lisp
+++ b/rdp/rdp.lisp
@@ -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))
diff --git a/tools/com.informatimago.tools.try-systems.asd b/tools/com.informatimago.tools.try-systems.asd
index 8eb1c17..b059907 100644
--- a/tools/com.informatimago.tools.try-systems.asd
+++ b/tools/com.informatimago.tools.try-systems.asd
@@ -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)

ViewGit