Add with-standard-io-syntax and protect lambda list on ECL/CLASP

code/extrinsic/packages.lisp

@@ -13,7 +13,8 @@
            #:pprint-pop
            #:pprint-tab
            #:pprint-tabular
-           #:set-pprint-dispatch)
+           #:set-pprint-dispatch
+           #:with-standard-io-syntax)
   (:export #:*client*
            #:*print-pprint-dispatch*
            #:*standard-pprint-dispatch*
@@ -30,4 +31,5 @@
            #:pprint-tab
            #:pprint-tabular
            #:pretty-stream-p
-           #:set-pprint-dispatch))
+           #:set-pprint-dispatch
+           #:with-standard-io-syntax))

code/extrinsic/print.lisp

@@ -17,3 +17,27 @@
         (funcall func stream object)
         (call-next-method)))
   object)
+
+(defmacro with-standard-io-syntax (&body body)
+  `(let ((*package* (find-package "CL-USER"))
+         (*print-array* t)
+         (*print-base* 10)
+         (*print-case* :upcase)
+         (*print-circle* nil)
+         (*print-escape* t)
+         (*print-gensym* t)
+         (*print-length* nil)
+         (*print-level* nil)
+         (*print-lines* nil)
+         (*print-miser-width* nil)
+         (*print-pprint-dispatch* *standard-pprint-dispatch*)
+         (*print-pretty* nil)
+         (*print-radix* nil)
+         (*print-readably* t)
+         (*print-right-margin* nil)
+         (*read-base* 10)
+         (*read-default-float-format* 'single-float)
+         (*read-eval* t)
+         (*read-suppress* nil)
+         (*readtable* (copy-readtable nil)))
+     ,@body))

code/form-printers.lisp

@@ -6,7 +6,7 @@
   #+clisp
     (system::arglist sym)
   #+(or clasp ecl)
-    (ext:function-lambda-list sym)
+    (with-standard-io-syntax (ext:function-lambda-list sym))
   #+sbcl
     (sb-introspect:function-lambda-list sym)
   #+lispworks

code/interface.lisp

@@ -30,6 +30,8 @@
                               :minimize :minimizing :nconc :nconcing :sum :summing
                               :unless :when)))
 
+(defgeneric make-dispatch-function (client pattern function rest))
+
 (defgeneric copy-pprint-dispatch (client table &optional read-only))
 
 (defgeneric pprint-dispatch (client table object))
@@ -187,75 +189,75 @@
          (pprint-exit-if-list-exhausted-func (intern "PPRINT-EXIT-IF-LIST-EXHAUSTED" intrinsic-pkg))
          (initialize-func (intern "INITIALIZE")))
     `(progn
-       (defmethod inravina:make-dispatch-function
+       (defmethod make-dispatch-function
            ((client ,client-class) (pattern (eql :client-stream-object)) function rest)
          (lambda (stream object)
-           (apply function ,client-var (inravina:make-pretty-stream ,client-var stream) object rest)))
-       (defmethod inravina:make-dispatch-function
+           (apply function ,client-var (make-pretty-stream ,client-var stream) object rest)))
+       (defmethod make-dispatch-function
            ((client ,client-class) (pattern (eql :client-object-stream)) function rest)
          (lambda (stream object)
-           (apply function ,client-var object (inravina:make-pretty-stream ,client-var stream) rest)))
-       (defmethod inravina:make-dispatch-function
+           (apply function ,client-var object (make-pretty-stream ,client-var stream) rest)))
+       (defmethod make-dispatch-function
            ((client ,client-class) (pattern (eql :stream-object)) function rest)
          (lambda (stream object)
-           (apply function (inravina:make-pretty-stream ,client-var stream) object rest)))
-       (defmethod inravina:make-dispatch-function
+           (apply function (make-pretty-stream ,client-var stream) object rest)))
+       (defmethod make-dispatch-function
            ((client ,client-class) (pattern (eql :object-stream)) function rest)
          (lambda (stream object)
-           (apply function object (inravina:make-pretty-stream ,client-var stream) rest)))
+           (apply function object (make-pretty-stream ,client-var stream) rest)))
        (defvar ,initial-pprint-dispatch-var nil)
        (defvar ,standard-pprint-dispatch-var nil)
        (defvar ,print-pprint-dispatch-var)
        (defun ,(intern "PRETTY-STREAM-P") (stream)
-         (inravina:pretty-stream-p ,client-var stream))
+         (pretty-stream-p ,client-var stream))
        (defun ,(intern "COPY-PPRINT-DISPATCH" intrinsic-pkg) (&optional (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
-         (check-type table (or null inravina::dispatch-table))
-         (inravina:copy-pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var)))
+         (check-type table (or null dispatch-table))
+         (copy-pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var)))
        (defun ,(intern "SET-PPRINT-DISPATCH" intrinsic-pkg)
            (type-specifier function &optional (priority 0) (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
          (check-type priority real)
-         (check-type table inravina::dispatch-table)
+         (check-type table dispatch-table)
          (check-type function (or symbol function))
-         (inravina:set-pprint-dispatch ,client-var table type-specifier function priority))
+         (set-pprint-dispatch ,client-var table type-specifier function priority))
        (defun ,(intern "PPRINT-FILL" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
-         (inravina:pprint-fill ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-fill ,client-var (coerce-output-stream-designator stream)
                                object colon-p at-sign-p)
          nil)
        (defun ,(intern "PPRINT-LINEAR" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
-         (inravina:pprint-linear ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-linear ,client-var (coerce-output-stream-designator stream)
                                  object colon-p at-sign-p)
          nil)
        (defun ,(intern "PPRINT-TABULAR" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p (tabsize 16))
-         (inravina:pprint-tabular ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-tabular ,client-var (coerce-output-stream-designator stream)
                                   object colon-p at-sign-p tabsize)
          nil)
        (defun ,(intern "PPRINT-INDENT" intrinsic-pkg) (relative-to n &optional stream)
          (check-type relative-to (member :block :current))
-         (inravina:pprint-indent ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-indent ,client-var (coerce-output-stream-designator stream)
                                  relative-to n)
          nil)
        (defun ,(intern "PPRINT-NEWLINE" intrinsic-pkg) (kind &optional stream)
          (check-type kind (member :linear :fill :miser :mandatory))
-         (inravina:pprint-newline ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-newline ,client-var (coerce-output-stream-designator stream)
                                   kind)
          nil)
        (defun ,(intern "PPRINT-TAB" intrinsic-pkg) (kind colnum colinc &optional stream)
          (check-type kind (member :line :section :line-relative :section-relative))
-         (inravina:pprint-tab ,client-var (inravina:coerce-output-stream-designator stream)
+         (pprint-tab ,client-var (coerce-output-stream-designator stream)
                               kind colnum colinc)
          nil)
        (defun ,(intern "PPRINT-DISPATCH" intrinsic-pkg) (object &optional (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
-         (check-type table (or null inravina::dispatch-table))
-         (inravina:pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var) object))
+         (check-type table (or null dispatch-table))
+         (pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var) object))
        (defmacro ,(intern "PPRINT-LOGICAL-BLOCK" intrinsic-pkg) ((stream-symbol object
                                         &key (prefix "" prefix-p)
                                           (per-line-prefix "" per-line-prefix-p)
                                           (suffix "" suffix-p))
                                        &body body)
-         (inravina:expand-logical-block ',client-var stream-symbol object
+         (expand-logical-block ',client-var stream-symbol object
                                         prefix prefix-p per-line-prefix per-line-prefix-p suffix suffix-p
                                         ',pprint-exit-if-list-exhausted-func ',pprint-pop-func
                                         body))
@@ -271,9 +273,9 @@
          (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
        (defun ,initialize-func (&aux *print-pretty*)
          (find-unquote-symbols)
-         (setf ,initial-pprint-dispatch-var (inravina:copy-pprint-dispatch ,client-var nil t)
-               ,standard-pprint-dispatch-var (inravina:copy-pprint-dispatch ,client-var nil t)
-               ,print-pprint-dispatch-var (inravina:copy-pprint-dispatch ,client-var nil))
+         (setf ,initial-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil t)
+               ,standard-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil t)
+               ,print-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil))
          ,@body))))
 
 (defgeneric execute-logical-block (client stream object function

code/native/print.lisp

@@ -54,4 +54,4 @@
   #+(or clasp ecl) (sys::pretty-stream-p stream)
   #+cmucl (pretty-print:pretty-stream-p stream)
   #+sbcl (sb-pretty:pretty-stream-p stream)
-  #-(or ccl clasp cmucl ecl sbcl) nil)
+  #-(or abcl ccl clasp cmucl ecl sbcl) nil)