Various: Try porting the code to CLisp.

Not entirely successful, largely because the CLisp pretty-printer seems
quite badly broken.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index c4c3e1748224af8bb00c0c73d3aa98363880ca71..8ba9a24bf7130c6f71bd04570d9f9e57eb42701b 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -119,7 +119,9 @@ (compile-time-defun pairify (x &optional (y nil defaultp))
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch

-    ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+    ((#\space #\tab #\newline #\return #\vt
+             #+cmu #\formfeed
+             #+clisp #\page) t)

     (t nil)))
 
 (declaim (ftype (function nil ()) slot-unitialized))
     (t nil)))
 
 (declaim (ftype (function nil ()) slot-unitialized))

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 51db744226852a8bb1f784be784f46b6d1fb5ae9..f274dcb17a88730350ee4c6fe0cd6f76b3285f05 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,7 +27,7 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
 ;;; Packages.
 
 (defpackage #:mdw.mop

-  (:use #:common-lisp #:mdw.base #+cmu #:mop)
+  (:use #:common-lisp #:mdw.base #+(or cmu clisp) #:mop)

   (:export #:compatible-class
           #:copy-instance #:copy-instance-using-class
           #:initargs-for-effective-slot #:make-effective-slot
   (:export #:compatible-class
           #:copy-instance #:copy-instance-using-class
           #:initargs-for-effective-slot #:make-effective-slot


@@ -123,6 +123,7 @@ (let ((stdslot (find-class 'standard-direct-slot-definition)))
   (defmethod compute-effective-slot-definition
       ((class compatible-class) slot-name direct-slots)
     "Construct an effective slot definition for the given slot."
   (defmethod compute-effective-slot-definition
       ((class compatible-class) slot-name direct-slots)
     "Construct an effective slot definition for the given slot."

+    (declare (ignore slot-name))

     ;;
     ;; Ideally we don't want to mess with a slot if it's entirely handled by
     ;; the implementation.  This check seems to work OK.
     ;;
     ;; Ideally we don't want to mess with a slot if it's entirely handled by
     ;; the implementation.  This check seems to work OK.


@@ -293,7 +294,7 @@ (defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."
 
 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."

-  (let ((class (pcl:class-of obj))
+  (let ((class (class-of obj))

         (magic (cons 'magic nil)))
     (print-unreadable-object (obj stream)
       (pprint-logical-block
         (magic (cons 'magic nil)))
     (print-unreadable-object (obj stream)
       (pprint-logical-block


@@ -304,8 +305,8 @@ (defun print-object-with-slots (obj stream)
                            (if (slot-boundp-using-class class obj slot)
                                (slot-value-using-class class obj slot)
                                magic)))
                            (if (slot-boundp-using-class class obj slot)
                                (slot-value-using-class class obj slot)
                                magic)))

-                   (pcl:class-slots class)))
-        (format stream "~S" (pcl:class-name class))
+                   (class-slots class)))
+        (format stream "~S" (class-name class))

         (let ((sep nil))
           (loop
             (pprint-exit-if-list-exhausted)
         (let ((sep nil))
           (loop
             (pprint-exit-if-list-exhausted)

diff --git a/mdw.asd b/mdw.asd
index 57c8b1442936a0bd908722d0b167a1fb18263125..2c689ab71e4d1f6324122b92ab4e39801c0616bd 100644 (file)
--- a/mdw.asd
+++ b/mdw.asd
@@ -15,8 +15,8 @@
               (:file "mdw-mop" :depends-on ("mdw-base"))
               (:file "str" :depends-on ("mdw-base"))
               (:file "collect" :depends-on ("mdw-base"))
               (:file "mdw-mop" :depends-on ("mdw-base"))
               (:file "str" :depends-on ("mdw-base"))
               (:file "collect" :depends-on ("mdw-base"))

-              (:file "unix" :depends-on ("mdw-base" "collect"))
-              (:file "safely" :depends-on ("mdw-base" "unix"))
+              #+cmu (:file "unix" :depends-on ("mdw-base" "collect"))
+              (:file "safely" :depends-on ("mdw-base"))

               (:file "infix")
               (:file "infix-ext" :depends-on ("mdw-base"
                                               "infix"
               (:file "infix")
               (:file "infix-ext" :depends-on ("mdw-base"
                                               "infix"

diff --git a/optparse-test b/optparse-test
index b5fe41f47be56e617c97888d984e26bfbe487f41..1d76566689d07ecce678bc7c91f8252d7639c900 100755 (executable)
--- a/optparse-test
+++ b/optparse-test
@@ -1,7 +1,8 @@
 #! /usr/local/bin/runlisp
 
 #! /usr/local/bin/runlisp
 

-;; (format t "Startup!~%")
-(asdf:operate 'asdf:load-op 'mdw :verbose nil)
+(let ((*compile-verbose* nil)
+      (*load-verbose* nil))
+  (asdf:oos 'asdf:load-op "mdw" :verbose nil))

 (use-package '#:optparse)
 
 (defvar opt-bool nil)
 (use-package '#:optparse)
 
 (defvar opt-bool nil)


@@ -46,11 +47,9 @@
             (read opt-object)
             (:doc (concatenate 'string
                                "Read object ("
             (read opt-object)
             (:doc (concatenate 'string
                                "Read object ("

-                               (format-universal-time nil
-                                                      (get-universal-time)
-                                                      :style :iso8601)
+                               (princ-to-string (get-universal-time))

                                ")")))
                                ")")))

-           (#\k "keywword" (:arg "KEYWORD") (keyword opt-keyword)
+           (#\k "keyword" (:arg "KEYWORD") (keyword opt-keyword)

                 ("Set an arbitrary keyword."))
            (#\e "enumeration" (:arg "ENUM")
                 (keyword opt-enum (list :apple :apple-pie :abacus :banana))
                 ("Set an arbitrary keyword."))
            (#\e "enumeration" (:arg "ENUM")
                 (keyword opt-enum (list :apple :apple-pie :abacus :banana))

diff --git a/sys-base.lisp b/sys-base.lisp
index 440facfaa68d7d5c9d87d99bbad6b15a70a2eb6e..b1e3595a973cff10b82673e2ea8b18e81e75f85c 100644 (file)
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -26,33 +26,45 @@
 (defpackage #:mdw.runlisp
   (:use #:common-lisp #+cmu #:extensions)
   (:export #:*lisp-interpreter* #:*command-line-strings*))
 (defpackage #:mdw.runlisp
   (:use #:common-lisp #+cmu #:extensions)
   (:export #:*lisp-interpreter* #:*command-line-strings*))

+(in-package #:mdw.runlisp)
+
+#+clisp
+(progn
+  (defvar *lisp-interpreter*)
+  (defvar *command-line-strings*)
+  (let ((args (coerce (ext:argv) 'list)))
+    (setf *lisp-interpreter* (car args))
+    (setf *command-line-strings* (nthcdr 7 args))))
+

 (defpackage #:mdw.sys-base
 (defpackage #:mdw.sys-base

-  (:use #:common-lisp #+cmu #:extensions #:mdw.runlisp)
-  (:export #:exit #:hard-exit #:*program-name* #:*command-line-strings*))
+  (:use #:common-lisp #+cmu #:extensions #+cmu #:mdw.runlisp)
+  (:export #:exit #:hard-exit #:*program-name* #:*command-line-strings*)
+  (:import-from #:mdw.runlisp #:*lisp-interpreter* #:*command-line-strings*)
+  #+clisp (:import-from #:ext #:exit))

 (in-package #:mdw.sys-base)
 
 ;;; --- This is currently all a bit CMUCL-specific ---
 
 (in-package #:mdw.sys-base)
 
 ;;; --- This is currently all a bit CMUCL-specific ---
 

-#+cmu
+#+(or cmu)

 (defun exit (&optional (code 0))
   "Polite way to end a program.  If running in an interactive Lisp, just
    return to the top-level REPL."
 (defun exit (&optional (code 0))
   "Polite way to end a program.  If running in an interactive Lisp, just
    return to the top-level REPL."

-  (if *batch-mode*
-      (throw 'lisp::%end-of-the-world code)
+  (if #+cmu *batch-mode*
+      #+cmu (throw 'lisp::%end-of-the-world code)

       (progn
         (unless (zerop code)
           (format t "~&Exiting unsuccessfully with code ~D.~%" code))
         (abort))))
 
       (progn
         (unless (zerop code)
           (format t "~&Exiting unsuccessfully with code ~D.~%" code))
         (abort))))
 

-#+cmu

 (defun hard-exit (&optional (code 0))
   "Stops the program immediately in its tracks.  Does nothing else.  Use
    after fork, for example, to avoid flushing buffers."
   (declare (type (unsigned-byte 32) code))
 (defun hard-exit (&optional (code 0))
   "Stops the program immediately in its tracks.  Does nothing else.  Use
    after fork, for example, to avoid flushing buffers."
   (declare (type (unsigned-byte 32) code))

-  (unix::void-syscall ("_exit" c-call:int) code))
+  #+cmu (unix::void-syscall ("_exit" c-call:int) code)
+  #+clisp (ext:quit code))

 
 

-#+cmu
-(defvar *program-name* (pathname-name (car *command-line-strings*))
+(defvar *program-name*
+  (pathname-name (car *command-line-strings*))

   "A plausible guess at the program's name, stripped of strange extensions.")
 
 ;;;----- That's all, folks --------------------------------------------------
   "A plausible guess at the program's name, stripped of strange extensions.")
 
 ;;;----- That's all, folks --------------------------------------------------