From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 24 May 2006 08:07:35 +0000 (+0100)
Subject: Various: Try porting the code to CLisp.
X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/8a2e8de1d736200d9aa751b85d5f97af33b91150

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 c4c3e17..8ba9a24 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -119,7 +119,9 @@
 (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))
diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 51db744..f274dcb 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,7 +27,7 @@
 ;;; 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
@@ -123,6 +123,7 @@
   (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.
@@ -293,7 +294,7 @@
 
 (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
@@ -304,8 +305,8 @@
                            (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)
diff --git a/mdw.asd b/mdw.asd
index 57c8b14..2c689ab 100644
--- 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 "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"
diff --git a/optparse-test b/optparse-test
index b5fe41f..1d76566 100755
--- a/optparse-test
+++ b/optparse-test
@@ -1,7 +1,8 @@
 #! /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)
@@ -46,11 +47,9 @@
 	     (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))
diff --git a/sys-base.lisp b/sys-base.lisp
index 440facf..b1e3595 100644
--- 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*))
+(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
-  (: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 ---
 
-#+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."
-  (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))))
 
-#+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))
-  (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 --------------------------------------------------