Introduce CHECKING-READER-CONDITIONALS

Author: metawilm

Diff for: contrib/lispy.lisp

@@ -274,10 +274,11 @@ STREAM can be an interactive (REPL) stream"
                  (when ch (unread-char ch stream)))))
            (should-unread-last-newline ()
              ;; In some implementations, leaving the #\Newline triggers printing new prompt.
-             #+allegro nil
-             #+ccl nil
-             #+sbcl t
-             #-(or allegro ccl sbcl) nil)
+             (checking-reader-conditionals
+              #+allegro nil
+              #+ccl nil
+              #+sbcl t
+              #-(or allegro ccl sbcl) nil))
 
            (read-complete-input ()
              (check-type stream concatenated-stream) ;; as created by omnivore readtable

Diff for: contrib/repl.lisp

@@ -363,12 +363,13 @@ KIND can be :ptime, :time, :space, :pspace or NIL."
             (locally (declare (special *stdout-softspace*))
               (setf *stdout-softspace* (py-bool nil)))
 
-            (unless #+(or allegro sbcl) (input-available-p)
-                    #-(or allegro sbcl) nil
-                    ;; When copy-pasting multiple lines of Python source code into the REPL,
-                    ;; prevent several prompts being printed below the copied code.
-                    (format t (nth (if acc 1 0) *prompts*))
-                    (force-output *standard-output*)) ;; stream T would mean *terminal-io*
+            (unless (checking-reader-conditionals
+                     #+(or allegro sbcl) (input-available-p)
+                     #-(or allegro sbcl) nil)
+              ;; When copy-pasting multiple lines of Python source code into the REPL,
+              ;; prevent several prompts being printed below the copied code.
+              (format t (nth (if acc 1 0) *prompts*))
+              (force-output *standard-output*)) ;; stream T would mean *terminal-io*
 
             (let ((x (read-line *standard-input* nil 'eof)))
               ;; XXX Let future debugger interface use *debug-io*?

Diff for: package.lisp

@@ -204,6 +204,7 @@
            #:alist-remove-prop #:+dict-alist-to-hashtable-threshold+
            #:+max-char-code+ #:char-code-type
            #:derive-pathname #:ensure-path-is-directory #:careful-probe-file
+           #:checking-reader-conditionals
            ;; finalization
            #:schedule-finalization #:unschedule-finalization
            ;; strings

Diff for: parser/lexer.lisp

@@ -594,10 +594,9 @@ Used by compiler to generate 'forbidden' identfiers.")
   "PYTHON-NAME has spaces as dividers, e.g. 'latin capital letter l with stroke'.
 Returns character or NIL."
   (when (plusp (length python-name))
-    (let* ((division-char #+(or allegro ccl sbcl) #\_
-                          #+lispworks #\-
-                          #-(or allegro ccl lispworks sbcl)
-                          (error "lisp-char-by-python-name not implemented"))
+    (let* ((division-char (checking-reader-conditionals 
+                           #+(or allegro ccl sbcl) #\_
+                           #+lispworks #\- ))
            (lisp-char-name (substitute division-char #\Space python-name)))
       (name-char lisp-char-name))))
 

Diff for: runtime/classes.lisp

@@ -414,11 +414,12 @@
   (make-instance cls))
 
 (defun classp (x)
-  #+allegro (excl::classp x)
-  #+cmu (pcl::classp x)
-  #+lispworks (clos::classp x)
-  #+sbcl (sb-pcl::classp x)
-  #-(or allegro cmu lispworks sbcl) (typep x 'class))
+  (checking-reader-conditionals
+   #+allegro (excl::classp x)
+   #+cmu (pcl::classp x)
+   #+lispworks (clos::classp x)
+   #+sbcl (sb-pcl::classp x)
+   #-(or allegro cmu lispworks sbcl) (typep x 'class)))
 
 (def-py-method py-class-method.__get__ (x inst class)
   (let ((arg (if (classp inst) inst (py-class-of inst))))
@@ -613,10 +614,11 @@
 ;; where instantiating a py-function leads to strange errors.
 ;; See <http://common-lisp.net/pipermail/clpython-devel/2008-May/000048.html>
 (defparameter *create-simple-lambdas-for-python-functions*
-    #+(or allegro lispworks) nil
-    #+sbcl t
-    #-(or allegro lispworks sbcl) t
-    "Whether Python function are real CLOS funcallable instances, or just normal lambdas.
+    (checking-reader-conditionals
+     #+(or allegro lispworks) nil
+     #+sbcl t
+     #-(or allegro lispworks sbcl) t)
+     "Whether Python function are real CLOS funcallable instances, or just normal lambdas.
 Note that in the latter case, functions miss their name and attribute dict, but should
 otherwise work well.")
 
@@ -2252,11 +2254,12 @@ But if RELATIVE-TO package name is given, result may contains dots."
        collect (make-tuple-from-list (list k v)))))
 
 (defparameter *hash-table-iterator-indefinite-extent*
-    #+allegro t
-    #+lispworks nil
-    #+sbcl t
-    #-(or allegro lispworks sbcl) nil
-    "Whether the iterator created by WITH-HASH-TABLE-ITERATOR has indefinite extent.
+    (checking-reader-conditionals
+     #+allegro t
+     #+lispworks nil
+     #+sbcl t
+     #-(or allegro lispworks sbcl) nil)
+     "Whether the iterator created by WITH-HASH-TABLE-ITERATOR has indefinite extent.
 ANSI states for WITH-HASH-TABLE-ITERATOR:  \"It is unspecified what happens if any
 of the implicit interior state of an iteration is returned outside the dynamic extent
 of the with-hash-table-iterator form such as by returning some closure over the
@@ -3804,13 +3807,13 @@ finished; F will then not be called again."
   "Return pointer address. This might change during the life time of the object,
 e.g. due to moving by the GC. Python has reference counting, and guarantees a
 fixed id during the object's lifetime."
-  (declare (ignorable x))
-  #+allegro (excl:lispval-to-address x)
-  #+ccl (ccl:%address-of x)
-  #+cmu (kernel:get-lisp-obj-address x)
-  #+lispworks (system:object-address x)
-  #+sbcl (sb-kernel:get-lisp-obj-address x)
-  #-(or allegro ccl cmu lispworks sbcl) (error "TODO: id() not implemented for this Lisp implementation"))
+  (checking-reader-conditionals
+   #+allegro (excl:lispval-to-address x)
+   #+ccl (ccl:%address-of x)
+   #+cmu (kernel:get-lisp-obj-address x)
+   #+ecl (error "py-id not implemented in :ecl")
+   #+lispworks (system:object-address x)
+   #+sbcl (sb-kernel:get-lisp-obj-address x)))
 
 (defgeneric py-cmp (x y)
   (:documentation
@@ -4083,9 +4086,10 @@ Returns one of (-1, 0, 1): -1 iff x < y; 0 iff x == y; 1 iff x > y")
 ;;; Printing with circle (recursion) detection
 
 (defvar *circle-detection-mechanism*
-    #+allegro :hash-table
-    #+(or cmu sbcl lispworks) :level
-    #-(or allegro cmu lispworks sbcl) :level)
+    (checking-reader-conditionals
+     #+allegro :hash-table
+     #+(or cmu sbcl lispworks) :level
+     #-(or allegro cmu lispworks sbcl) :level))
 
 (defvar *circle-print-abbrev* "...")
 

Diff for: runtime/dictattr.lisp

@@ -65,29 +65,28 @@
     (class-slot-ix 'dict 'py-type 'py-meta-type))
 
 (defconstant-once +py-class-classname-slot-name+
-  #+allegro 'excl::name
-  #+ccl 'ccl::name
-  #+cmu 'pcl::name
-  #+ecl 'clos::name
-  #+lispworks 'clos::name
-  #+sbcl 'sb-pcl::name
-  #-(or allegro ccl cmu ecl lispworks sbcl) 
-  (break "Define slot name containing class name, for this implementation."))
+    (checking-reader-conditionals
+     #+allegro 'excl::name
+     #+ccl 'ccl::name
+     #+cmu 'pcl::name
+     #+ecl 'clos::name
+     #+lispworks 'clos::name
+     #+sbcl 'sb-pcl::name))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
   (defconstant +use-standard-instance-access+
-    #+ #1=ecl nil
-    #+ #2=(or allegro ccl cmu lispworks sbcl) t
-    #- (or #1# #2#) (break "Define +use-standard-instance-access+"))
+      (checking-reader-conditionals
+       #+ecl nil
+       #+(or allegro ccl cmu lispworks sbcl) t))
 
   (register-feature :clpython-use-standard-instance-access +use-standard-instance-access+)
 
   (defconstant +use-standard-instance-access-setf+
-    #+(or allegro ccl lispworks sbcl) t
-    #+(or cmu ecl) nil ;; these lack (SETF STANDARD-INSTANCE-ACCESS)
-    #-(or allegro ccl cmu ecl lispworks sbcl) (break "Define +use-standard-instance-access-setf+ ~
-for this implementation"))
+      (checking-reader-conditionals
+       #+(or allegro ccl lispworks sbcl) t
+       #+(or cmu ecl) nil ;; these lack (SETF STANDARD-INSTANCE-ACCESS)
+       ))
 
   (register-feature :clpython-use-standard-instance-access-setf +use-standard-instance-access-setf+))
 

Diff for: util/utils.lisp

@@ -106,12 +106,20 @@ If the stream length can not be determined (e.g. for standard input), all availa
                    ((equal array-element-type '(unsigned-byte 8))
                     (map 'string #'code-char vec))))))
 
+(defmacro checking-reader-conditionals (&whole whole &body body)
+  "Break unless the body contains exactly one form. Based on idea from Steve Haflich."
+  (let ((num (length body)))
+    (unless (= num 1)
+      (break "A CHECKING-READER-CONDITIONALS expression returned ~r forms: ~s" num whole))
+    (car body)))
+
 (defmacro named-function (name lambda-form)
   (declare (ignorable name))
   (assert (eq (car lambda-form) 'lambda))
-  #+allegro `(excl:named-function ,name ,lambda-form)
-  #+sbcl `(sb-int:named-lambda ,name ,@(cdr lambda-form)) ;; skip 'lambda symbol
-  #-(or allegro sbcl) lambda-form)
+  (checking-reader-conditionals
+   #+allegro `(excl:named-function ,name ,lambda-form)
+   #+sbcl `(sb-int:named-lambda ,name ,@(cdr lambda-form)) ;; skip 'lambda symbol
+   #-(or allegro sbcl) lambda-form))
 
 (defmacro with-stack-list ((name &rest items) &body body)
   (check-type name symbol)
@@ -124,11 +132,12 @@ If the stream length can not be determined (e.g. for standard input), all availa
      ,@body))
 
 (defmacro without-redefinition-warnings (&body body)
-  #+allegro `(excl:without-redefinition-warnings ,@body)
-  #+lispworks `(system::without-warning-on-redefinition ,@body)
-  #+sbcl `(handler-bind ((sb-kernel:redefinition-warning #'muffle-warning))
-            ,@body)
-  #-(or allegro lispworks sbcl) `(progn ,@body))
+  (checking-reader-conditionals
+   #+allegro `(excl:without-redefinition-warnings ,@body)
+   #+lispworks `(system::without-warning-on-redefinition ,@body)
+   #+sbcl `(handler-bind ((sb-kernel:redefinition-warning #'muffle-warning))
+             ,@body)
+   #-(or allegro lispworks sbcl) `(progn ,@body)))
 
 (defmacro fast (&body body)
   `(locally (declare (optimize (speed 3)))
@@ -142,11 +151,12 @@ If the stream length can not be determined (e.g. for standard input), all availa
 
 
 (defconstant-once +max-char-code+
-    ;; On Allegro CHAR-CODE-LIMIT is the largest value across all
-    ;; implementations, while EXCL:REAL-CHAR-CODE-LIMIT. is "a better estimate".
-    ;; http://www.franz.com/support/documentation/8.1/doc/variables/excl/real-char-code-limit.htm
-    #+allegro (progn (assert (<= excl:real-char-code-limit char-code-limit))
-                     excl:real-char-code-limit)
+    #+allegro (progn
+                ;; On Allegro CHAR-CODE-LIMIT is the largest value across all
+                ;; implementations, while EXCL:REAL-CHAR-CODE-LIMIT. is "a better estimate".
+                ;; http://www.franz.com/support/documentation/8.1/doc/variables/excl/real-char-code-limit.htm
+                (assert (<= excl:real-char-code-limit char-code-limit))
+                excl:real-char-code-limit)
     #-allegro char-code-limit
     "Like CHAR-CODE-LIMIT, but possible lower.")
 
@@ -235,26 +245,17 @@ See function ALIST-VS-HT.")
   ;; Adapted from Rob Warnock's post "How to programmatically exit?"
   ;;  http://groups.google.nl/group/comp.lang.lisp/msg/94c9a579608dcd9a
   (declare (ignorable code))
-  #+allegro (excl:exit code :quiet t) ;; added (:quiet t) -WB
-  #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
-  #+cmu (ext:quit code)
-  #+cormanlisp (win32:exitprocess code)
-  #+gcl (lisp:bye code)                 ; XXX Or is it LISP::QUIT?
-  #+lispworks (lw:quit :status code)
-  #+lucid (lcl:quit code)
-  #+sbcl (sb-ext:quit
-          :unix-status (typecase code (number code)
-                                 (null 0)
-                                 (t 1)))
-  #+kcl (lisp::bye)                     ; XXX Does this take an arg?
-  #+scl (ext:quit code)                 ; XXX Pretty sure this *does*.
-  #+(or openmcl mcl) (ccl::quit)
-  #+abcl (cl-user::quit)
-  #+ecl (si:quit)
-  #+poplog (poplog::bye)                ; XXX Does this take an arg?
-  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl
-        kcl scl openmcl mcl abcl ecl poplog)
-  (error "QUIT not-implemented in this implementation"))
+  (checking-reader-conditionals
+   #+allegro (excl:exit code :quiet t)
+   #+cmu (ext:quit code)
+   #+lispworks (lw:quit :status code)
+   #+sbcl (sb-ext:quit :unix-status (typecase code (number code)
+                                              (null 0)
+                                              (t 1)))
+   #+(or openmcl mcl) (ccl::quit)
+   #+abcl (cl-user::quit)
+   #+ecl (si:quit)
+   ))
 
 (defun abbreviate-to-one-line (string)
   (loop for i from 0
@@ -287,10 +288,10 @@ See function ALIST-VS-HT.")
 #+(or)
 (defun directory-p (pathname)
   (check-type pathname pathname)
-  #+allegro (excl:file-directory-p pathname)
-  #+lispworks (lispworks:file-directory-p pathname)
-  #+(or cmu sbcl) (null (pathname-type pathname))
-  #-(or allegro cmu lispworks sbcl) (error "TODO: No DIRECTORY-P for this implementation."))
+  (checking-reader-conditionals
+   #+allegro (excl:file-directory-p pathname)
+   #+lispworks (lispworks:file-directory-p pathname)
+   #+(or cmu sbcl) (null (pathname-type pathname))))
 
 (defmacro with-line-prefixed-output ((prefix) &body body)
   (check-type prefix string)
@@ -347,4 +348,4 @@ See function ALIST-VS-HT.")
 (defun careful-probe-file (pathspec)
   "Like PROBE-FILE, but this function never signals FILE-ERROR: that is mapped to NIL."
   (handler-case (probe-file pathspec)
-    (file-error () nil)))
+    (file-error () nil)))