Checkpointing from my Mac

7 files changed, 151 insertions, 16 deletions

diff --git a/abs-syn.lsp b/abs-syn.lsp
index a339a47..5963381 100644
--- a/abs-syn.lsp
+++ b/abs-syn.lsp
@@ -1,3 +1,25 @@
+(defpackage #:abs-syn
+  (:use #:openlisp)
+  (:export
+   #:<exp-int>
+   #:<exp-var>
+   #:<exp-str>
+   #:<exp-unr>
+   #:<exp-bin>
+   #:<cmd-rem>
+   #:<cmd-goto>
+   #:<cmd-print>
+   #:<cmd-input>
+   #:<cmd-if>
+   #:<cmd-let>
+   #:<phrase-line>
+   #:<phrase-list>
+   #:<phrase-run>
+   #:<phrase-p-end>
+   #:priority-uop
+   #:priority-binop))
+(in-package #:abs-syn)
+
 ;; If these were only C enums, without any payload, I'd just use symbols and (error) in the t case.
 ;; But classes seem better for the associated data, in discriminated unions.
 
@@ -35,3 +57,4 @@
     ((eql bin-op 'mod) 4)
     ((member bin-op '(equal less lesseq great greateq diff)) 3)
     ((member bin-op '(and or)) 2)))
+(provide "abs-syn")
diff --git a/basic.lsp b/basic.lsp
index 571d4a6..7f13acd 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -1,9 +1,19 @@
-#!/home/snuc/openlisp-10.9.0/uxlisp -shell
+#!/Users/dbane/openlisp-11.0.0/uxlisp -shell
+
+(require "abs-syn")
+(require "lex")
+(require "parse")
+(defpackage #:basic
+  (:use #:openlisp)
+  (:export
+   #:main))
+(in-package #:basic)
 
 ;;; Not sure yet if it's a good idea or not,
 ;;; but I'm trying to keep the number of top-level functions the same as in OCaml.
 
 (defun one-command (st)
+   (format (standard-output) "> ")
    (with-handler #'error-handler
       (let ((l parse (read-line)))
            (case (car l)
@@ -18,9 +28,10 @@
 
 (defun main ()
    (catch 'end (lambda ()
-                  (format (standard-output) "OpenCOMAL version 0.4~%~%")
+                  (format (standard-output) "BASIC version 0.1~%~%")
                   (for ((st (create (class <state>))))
                        (())
                        (format (standard-output) "> ")
                        (catch 'error (one-command st)))))
    (format (standard-output) "See you later...~%"))
+(provide "basic")
diff --git a/bitmap.lsp b/bitmap.lsp
index e4cdea3..41d3f64 100644
--- a/bitmap.lsp
+++ b/bitmap.lsp
@@ -79,9 +79,9 @@
 
 ;;; Read a PPM file
 
-(defconstant +whitespaces-chars+ '(#\SPACE #\RETURN #\TAB #\NEWLINE #\LINEFEED))
+(defconstant +whitespace-chars+ '(#\SPACE \#carriage-return #\TAB #\NEWLINE))
 
-(defun read-header-chars (stream &optional (delimiter-list +whitespaces-chars+))
+(defun read-header-chars (stream &optional (delimiter-list +whitespace-chars+))
    (do ((c (read-char stream nil :eof)
            (read-char stream nil :eof))
         (vals nil (if (or (null c) (char= c  #\#)) vals (cons c vals))))   ;;don't collect comment chars
diff --git a/dbc.lsp b/dbc.lsp
index 48f1d6f..fc6e5d0 100644
--- a/dbc.lsp
+++ b/dbc.lsp
@@ -4,7 +4,8 @@
 (defcontract average-of-absolutes (values)
    (:in ()
 	(assure <list> values)
-	(> (length values) 0))		; Redundant?
+	(> (length values) 0))		; Not redundant, nil is an instance of <list>.
+                                        ; Could have used <cons> instead I guess.
    (:out (res)
 	 (assure <integer> res)
 	 (>= res 0))
diff --git a/lex.lsp b/lex.lsp
index 52eb822..9f10a03 100644
--- a/lex.lsp
+++ b/lex.lsp
@@ -1,4 +1,20 @@
-(defclass <string-lexer> () ((string :initarg :s :accessor string)
+(defpackage #:lex
+  (:use #:openlisp)
+  (:export
+   #:<lint>
+   #:<lsymbol>
+   #:<lstring>
+   #:<lend>))
+(in-package #:lex)
+
+(defclass <lexeme> () () (:abstractp t))
+(defclass <lint> (<lexeme>) ((int :reader int)))
+(defclass <lident> (<lexeme>) ((ident :reader ident)))
+(defclass <lsymbol> (<lexeme>) ((lsymbol :reader lsymbol)))
+(defclass <lstring> (<lexeme>) ((lstring :reader lstring)))
+(defclass <lend> (<lexeme>) ())
+
+(defclass <string-lexer> () ((string :initarg s :accessor string)
                              (current :initform 0 :accessor current)
                              (size :accessor size)))
 
@@ -26,16 +42,16 @@
 
 (defgeneric extract-int (cl))
 (defmethod extract-int ((cl <string-lexer>))
-  ;; TODO: flet?
-  (let ((is-int (lambda (x)
-                  (and (char>= x #\0) (char<= x #\9)))))
-    (convert (extract is-int cl) <number>)))
+   (flet ((is-int (x)
+             (and (char>= x #\0) (char<= x #\9))))
+      (convert (extract is-int cl) <number>)))
 
 (defgeneric extract-ident (cl))
 (defmethod extract-ident ((cl <string-lexer>))
-  (let ((is-alpha-num (lambda (x)
-                        (or (and (char>= x #\a) (char<= x #\z))
-                          (and (char>= x #\A) (char<= x #\Z))
-                          (and (char>= x #\0) (char<= x #\9))
-                          (char= x #\_)))))
-    (extract is-alpha-num)))
+   (flet ((is-alpha-num (x)
+             (or (and (char>= x #\a) (char<= x #\z))
+                 (and (char>= x #\A) (char<= x #\Z))
+                 (and (char>= x #\0) (char<= x #\9))
+                 (char= x #\_))))
+      (extract is-alpha-num)))
+(provide "lex")
diff --git a/loot.lsp b/loot.lsp
new file mode 100755
index 0000000..6192dbf
--- /dev/null
+++ b/loot.lsp
@@ -0,0 +1,41 @@
+;;; Port of https://en.wikipedia.org/wiki/ModernPascal#Code_Sample[3].
+;;; And then to CL.
+;;; I prefer my version.
+(defconstant +max-probability+ 1000)
+;; Because this is a simple enum and not a full sum/product type,
+;; I use symbols instead of CLOS.
+(defconstant +loot-type+ (vector 'bloodstone 'copper 'emeraldite 'gold
+                           'heronite 'platinum 'shadownite 'silver
+                           'soranite 'umbrarite 'cobalt 'iron
+                           'nothing))
+(defclass <looter> () ((probabilities :accessor probabilities)))
+(defgeneric choose (self))
+(defmethod choose ((self <looter>))
+  (let ((random-value (random (- +max-probability+ 1))))
+    (do ((loop 0 (+ loop 1)))
+        ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13))))))
+(defmethod initialize-instance :after ((self <looter>) &rest initargs)
+  (setf (probabilities self) (vector 10 77 105 125 142 159 172 200 201 202 216 282 +max-probability+)))
+(defun as-string (l)
+  ;; Could use assoc here, but this is closer to the original.
+  ;; Also saves translating nil to "".
+  (case l
+    ((bloodstone) "Bloodstone")
+    ((copper) "Copper")
+    ((emeraldite) "Emeraldite")
+    ((gold) "Gold")
+    ((heronite) "Heronite")
+    ((platinum) "Platinum")
+    ((shadownite) "Shadownite")
+    ((silver) "Silver")
+    ((soranite) "Soranite")
+    ((umbrarite) "Umbrarite")
+    ((cobalt) "Cobalt")
+    ((iron) "Iron")
+    (t "")))
+(defun main ()
+  (let ((loot (make-instance (find-class '<looter>))))
+    (do ((n 0 (+ n 1)))
+      ((> n 99))
+      (format *standard-output* "~A~%" (as-string (choose loot))))))
+(main)
diff --git a/parse.lsp b/parse.lsp
new file mode 100644
index 0000000..9bedee3
--- /dev/null
+++ b/parse.lsp
@@ -0,0 +1,43 @@
+(defpackage #:parse
+  (:use #:openlisp #:lex #:abs-syn)
+  (:export
+   #:parse))
+(in-package #:parse)
+
+(defclass <exp-elem> () () (:abstractp t))
+(defclass <elem-exp> (<exp-elem>) ((expr :accessor expr)))
+(defclass <elem-bin> (<exp-elem>) ((bin-op :accessor bin-op)))
+(defclass <elem-unr> (<exp-elem>) ((unr-op :accessor unr-op)))
+(defclass <elem-lp> (<exp-elem) ())
+
+(defun unr-symb (s)
+  (cond ((string= s "!") 'not)
+	((string= s "-") 'uminus)
+	(t (error "Parse error"))))
+
+(defun bin-symb (s)
+  (cond ((string= s "+") 'plus)
+	((string= s "-") 'minus)
+	((string= s "*") 'mult)
+	((string= s "/") 'div)
+	((string= s "%") 'mod)
+	((string= s "=") 'equal)
+	((string= s "<") 'less)
+	((string= s "<=") 'lesseq)
+	((string= s ">") 'great)))
+
+(defun parse (str)
+  (let* ((cl (init-lex str))
+	 (tok (lexer cl)))
+    (cond ((instancep tok (class <lint>))
+	   (make-instance (class <line>) 'n n 'c (parse-cmd cl)))
+	  ((instancep tok (class <lident>))
+	   (cond ((string= (ident tok) "LIST")
+		  (create (class <phrase-list>)))
+		 ((string= (ident tok) "RUN")
+		  (create (class <phrase-run>)))
+		 ((string= (ident tok) "END")
+		  (create (class <phrase-p-end>)))
+		 (t (error "Parse error"))))
+	  (t (error "Parse error")))))
+(provide "parse")