From 31a933ffe1617cf912dea58b8bb856183f7668f1 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Mon, 18 Jan 2021 09:57:31 +0000 Subject: Commit local changes before pulling from upstream --- cecho.lisp | 10 ++++++++++ cxdrt.lisp | 3 +++ doc/breaking_rules.md | 4 ++-- 3 files changed, 15 insertions(+), 2 deletions(-) create mode 100644 cecho.lisp diff --git a/cecho.lisp b/cecho.lisp new file mode 100644 index 0000000..9624712 --- /dev/null +++ b/cecho.lisp @@ -0,0 +1,10 @@ +(ql:quickload "jsonrpc") +(require "jsonrpc") ; Required? +(defun main () + (let ((server (jsonrpc:make-server))) + (jsonrpc:expose server "subtract" (lambda (args) + (- (gethash "l" args) (gethash "r" args)))) + (jsonrpc:expose server "add" (lambda (args) + (+ (gethash "l" args) (gethash "r" args)))) + (jsonrpc:expose server "quit" (lambda (args) (quit))) + (jsonrpc:server-listen server :port 8192 :mode :tcp))) diff --git a/cxdrt.lisp b/cxdrt.lisp index 6c84657..3e95334 100644 --- a/cxdrt.lisp +++ b/cxdrt.lisp @@ -1,3 +1,6 @@ +;;; Depends on the "frpc" package from QuickLisp +(ql:quickload "frpc") + (defun xwrt (fname) (with-open-file (f fname :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (frpc:write-xtype :int32 f 1234) diff --git a/doc/breaking_rules.md b/doc/breaking_rules.md index 0c34594..0eb3474 100644 --- a/doc/breaking_rules.md +++ b/doc/breaking_rules.md @@ -88,7 +88,7 @@ Even though this is a prototype, attention should be paid to basic craftsmanship * Divide the system into packages, using the subset of CL that is supported by OpenLisp -* Write one-sentence docstrings for at least each public fun and class +* Write one-sentence docstrings for at least each public fun, class, and package * Use `declare` to check the types of parameters in public interfaces (see below). * Indent all the source code using Emacs. @@ -194,7 +194,7 @@ But it's not worth writing custom rules. ### UI ltk is great for local GUIs. -However, a product may require HTMX and the platform.sh stack. +However, a product may (or may not) require HTMX and the platform.sh stack. Note that I prefer HTMX & ReST (following Fielding) to single-page applications (outside the very specific case of drawing on a canvas using ParenScript). -- cgit 1.4.1-2-gfad0 From 6d6911084595fe755311b875753295beba71c1c8 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Tue, 26 Jan 2021 22:01:42 +0000 Subject: Switching computers for a while --- clex.lisp | 2 +- doc/macros.ms | 115 ---------------------------------------------------------- loot.lsp | 92 +++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 83 insertions(+), 126 deletions(-) delete mode 100755 doc/macros.ms diff --git a/clex.lisp b/clex.lisp index 7ca04f0..25d86d4 100644 --- a/clex.lisp +++ b/clex.lisp @@ -79,5 +79,5 @@ ((member c '(#\< #\>)) (forward cl) - ) + )))))) (provide "clex") diff --git a/doc/macros.ms b/doc/macros.ms deleted file mode 100755 index e95e98b..0000000 --- a/doc/macros.ms +++ /dev/null @@ -1,115 +0,0 @@ -.de F1 -.nr OI \\n(.iu -.nr PW 1v -.KF -.sp 0.3v -.. -.de T1 -.F1 -.. -.de F2 -.ds Fp Figure\ \\n(Fi -.ds Fn Figure\ \\n+(Fi -.ds Fq \\*(Fp -.F0 -.. -.de T2 -.ds Tp Table\ \\n(Ti -.ds Tn Table\ \\n+(Ti -.ds Tq \\*(Tp -.T0 -.. -.de F0 -.nr BD 1 -.if t .ps \\n(PS-1 -.ie \\n(VS>=41 .vs \\n(VSu-1p -.el .vs \\n(VSp-1p -.ft 1 -.di DD -.ll \\n(.lu*3u/4u -.in 0 -.fi -.ad b -.sp 0.5v -\f3\\*(Fq\f1\ \ \c -.. -.de T0 -.nr BD 1 -.if t .ps \\n(PS-1 -.ie \\n(VS>=41 .vs \\n(VSu-1p -.el .vs \\n(VSp-1p -.ft 1 -.di DD -.ll \\n(.lu*3u/4u -.in 0 -.fi -.ad b -.sp 0.5v -\f3\\*(Tq\f1\ \ \c -.. -.de F3 -.sp 0.5v -.di -.br -.ll \\n(.lu*4u/3u -.if \\n(dl>\\n(BD .nr BD \\n(dl -.if \\n(BD<\\n(.l .in (\\n(.lu-\\n(BDu)/2u -.nf -.DD -.in \\n(OIu -.nr BD 0 -.fi -.KE -.ie \\n(VS>=41 .vs \\n(VSu -.el .vs \\n(VSp -.. -.de T3 -.F3 -.. -.de EX -.\" P1 -.DS L -.ft CW -\s-4 -.. -.de EE -\s+4 -.\" P2 -.ft -.DE -.. -.nr Fi 1 +1 -.nr Ti 1 +1 -.ds Fn Figure\ \\n(Fi -.ds Tn Table\ \\n(Ti -.nr XP 2 \" delta point size for program -.nr XV 2p \" delta vertical for programs -.nr XT 4 \" delta tab stop for programs -.nr DV .5v \" space before start of program -.\" FP lucidasans -.nr PS 11 -.nr VS 13 -.\" nr LL 6.6i -.\" nr PI 0 \" paragraph indent -.nr PD 4p \" extra space between paragraphs -.\" pl 11i -.rm CH -.de L= -.ie '\\$1'sec' .NH \\$2 -.el .ie '\\$1'table' .if !'\\$3'*' \{ -.DS C -Table '\\$3' about here -.DE -\} -.el .if '\\$1'fig' .if !'\\$3'*' \{ -.DS C -Figure '\\$3' about here -.DE -\} -.. -.de R1 -.ig R2 -.. -.\" -.\" groff-specific: -.ds FAM H diff --git a/loot.lsp b/loot.lsp index 727f8f3..857c7af 100644 --- a/loot.lsp +++ b/loot.lsp @@ -1,5 +1,5 @@ ;;; Port of https://en.wikipedia.org/wiki/ModernPascal#Code_Sample[3]. -;;; And then to CL. +;;; And then to CL and ISLisp. ;;; I prefer my version. (defconstant +max-probability+ 1000) ;; Because this is a simple enum and not a full sum/product type, @@ -15,11 +15,7 @@ (for ((loop 0 (+ loop 1))) ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13)))))) (defmethod initialize-object :after ((self ) 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 + (setf (probabilities self) (vector 10 77 105 125 142 159 172 200 201 202 216 282 +max-probability+ (case l ((bloodstone) "Bloodstone") ((copper) "Copper") ((emeraldite) "Emeraldite") @@ -34,8 +30,84 @@ ((iron) "Iron") (t ""))) (defun main () - (let ((loot (create (class )))) - (for ((n 0 (+ n 1))) - ((> n 99)) + (let ((loot (create (class ))) (for ((n 0 (+ n 1))) + + ((> n 99)) (format (standard-output) "~A~%" (as-string (choose loot)))))) -(main) + + +. /usr/local/plan9/bin/9.rc +if (test -d /usr/local/bin) { + path = (/usr/local/bin $path) +} +if (test -d /usr/local/opt/emacs-plus/bin) { + path = ($path /usr/local/opt/emacs-plus/bin) +} +if (test -d $home/bin) { + path = ($path $home/bin) +} +if (test -d $home/opt/GNAT/2020/bin) { + path = ($home/opt/GNAT/2020/bin $path) +} + +OPENLISP = $home/openlisp-11.0.0 +if (test -d $OPENLISP) { + path = ($path $OPENLISP) +} + +# These break some commands like man. +# Use the new names instead. +#fn grep { rg $* } +#fn ls { exa $* } +#fn find { fd $* } +#fn cat { bat $* } +#fn more { bat $* } +#fn xterm { alacritty $* } + +#prompt = ('$ ' '$ ') +REFER = $home/lsp/doc/refs + +if (test -d $home/.cargo/bin) { + path = ($home/.cargo/bin $path) +} + +if (test -d /usr/local/opt/tcl-tk/bin) { + path = (/usr/local/opt/tcl-tk/bin $path) +} + +if (test -d $home/obnc/usr/local/bin) { + path = ($path $home/obnc/usr/local/bin) +} + +if (test -d $home/.emacs.d/bin) { + path = ($path $home/.emacs.d/bin) +} +fn doom { u doom $* } +if (test -d /Applications/Emacs.app/Contents/MacOS/bin) { + path = ($path /Applications/Emacs.app/Contents/MacOS/bin) +} +if (test -f /Applications/Emacs.app/Contents/MacOS/Emacs) { + EMACS = /Applications/Emacs.app/Contents/MacOS/Emacs + fn emacs { u $EMACS -nw $* } +} +if (test -f /Applications/Emacs.app/Contents/MacOS/bin/emacsclient) { + fn emacsclient { u /Applications/Emacs.app/Contents/MacOS/bin/emacsclient $* } +} + +LANG = en_IE.UTF-8 +TZ = Europe/Dublin +LESS_IS_MORE = t +MORE = '-SEXIER' +POSIXLY_CORRECT = t +REFER = $home/lsp/doc/refs + +if (test -d $home/context/tex/texmf-osx-64/bin) { + path = ($path $home/context/tex/texmf-osx-64/bin) +} + +if (test -d $home/Library/Python/3.8/bin) { + path = ($path $home/Library/Python/3.8/bin) +} + +TCLLIBPATH = $home/lib/tklib0.7 + -- cgit 1.4.1-2-gfad0 From 9dbb4b1c10aa87c1b296752467ec6d6983247aa6 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Wed, 27 Jan 2021 19:52:36 +0000 Subject: Fix after editor vomited everywhere --- loot.lsp | 132 +++++++++++++++------------------------------------------------ 1 file changed, 30 insertions(+), 102 deletions(-) diff --git a/loot.lsp b/loot.lsp index 857c7af..4dfb2c8 100644 --- a/loot.lsp +++ b/loot.lsp @@ -4,110 +4,38 @@ (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 'shaownite 'silver - 'soranite 'umbrarite 'cobalt 'iron - 'nothing)) +(defconstant +loot-type+ #(bloodstone copper emeraldite gold + heronite platinum shadownite silver + soranite umbrarite cobalt iron + nothing)) (defclass () ((probabilities :accessor probabilities))) (defgeneric choose (self)) (defmethod choose ((self )) - (let ((random-value (random (- +max-probability+ 1)))) - (for ((loop 0 (+ loop 1))) - ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13)))))) + (let ((random-value (random (- +max-probability+ 1)))) + (for ((loop 0 (+ loop 1))) + ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13)))))) (defmethod initialize-object :after ((self ) initargs) - (setf (probabilities self) (vector 10 77 105 125 142 159 172 200 201 202 216 282 +max-probability+ (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 ""))) + (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 (create (class ))) (for ((n 0 (+ n 1))) - - ((> n 99)) - (format (standard-output) "~A~%" (as-string (choose loot)))))) - - -. /usr/local/plan9/bin/9.rc -if (test -d /usr/local/bin) { - path = (/usr/local/bin $path) -} -if (test -d /usr/local/opt/emacs-plus/bin) { - path = ($path /usr/local/opt/emacs-plus/bin) -} -if (test -d $home/bin) { - path = ($path $home/bin) -} -if (test -d $home/opt/GNAT/2020/bin) { - path = ($home/opt/GNAT/2020/bin $path) -} - -OPENLISP = $home/openlisp-11.0.0 -if (test -d $OPENLISP) { - path = ($path $OPENLISP) -} - -# These break some commands like man. -# Use the new names instead. -#fn grep { rg $* } -#fn ls { exa $* } -#fn find { fd $* } -#fn cat { bat $* } -#fn more { bat $* } -#fn xterm { alacritty $* } - -#prompt = ('$ ' '$ ') -REFER = $home/lsp/doc/refs - -if (test -d $home/.cargo/bin) { - path = ($home/.cargo/bin $path) -} - -if (test -d /usr/local/opt/tcl-tk/bin) { - path = (/usr/local/opt/tcl-tk/bin $path) -} - -if (test -d $home/obnc/usr/local/bin) { - path = ($path $home/obnc/usr/local/bin) -} - -if (test -d $home/.emacs.d/bin) { - path = ($path $home/.emacs.d/bin) -} -fn doom { u doom $* } -if (test -d /Applications/Emacs.app/Contents/MacOS/bin) { - path = ($path /Applications/Emacs.app/Contents/MacOS/bin) -} -if (test -f /Applications/Emacs.app/Contents/MacOS/Emacs) { - EMACS = /Applications/Emacs.app/Contents/MacOS/Emacs - fn emacs { u $EMACS -nw $* } -} -if (test -f /Applications/Emacs.app/Contents/MacOS/bin/emacsclient) { - fn emacsclient { u /Applications/Emacs.app/Contents/MacOS/bin/emacsclient $* } -} - -LANG = en_IE.UTF-8 -TZ = Europe/Dublin -LESS_IS_MORE = t -MORE = '-SEXIER' -POSIXLY_CORRECT = t -REFER = $home/lsp/doc/refs - -if (test -d $home/context/tex/texmf-osx-64/bin) { - path = ($path $home/context/tex/texmf-osx-64/bin) -} - -if (test -d $home/Library/Python/3.8/bin) { - path = ($path $home/Library/Python/3.8/bin) -} - -TCLLIBPATH = $home/lib/tklib0.7 - + (let ((loot (create (class )))) + (for ((n 0 (+ n 1))) + ((> n 99)) + (format (standard-output) "~A~%" (as-string (choose loot)))))) +(main) -- cgit 1.4.1-2-gfad0 From 6498dfe047b90ac719b9a41d644d9e72ffaa11a4 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Sun, 31 Jan 2021 16:21:42 +0000 Subject: Some new ISLisp --- basic.lsp | 2 +- cap-muck.lsp | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++ dbm.lsp | 27 ++++++++ doc/breaking_rules.md | 3 +- 4 files changed, 213 insertions(+), 2 deletions(-) create mode 100644 cap-muck.lsp create mode 100644 dbm.lsp diff --git a/basic.lsp b/basic.lsp index 11771e9..135c2ba 100644 --- a/basic.lsp +++ b/basic.lsp @@ -1,4 +1,4 @@ -#!/Users/dbane/openlisp-11.0.0/uxlisp -shell +#!/home/dbane/openlisp-11.0.0/uxlisp -shell (require "abs-syn") (require "lex") diff --git a/cap-muck.lsp b/cap-muck.lsp new file mode 100644 index 0000000..fd90626 --- /dev/null +++ b/cap-muck.lsp @@ -0,0 +1,183 @@ +(defpackage #:cap-muck + (:use #:openlisp) + (:export + #:main) + ) +(in-package #:cap-muck) +(defglobal *terminate-program* nil) + +(defconstant +bold+ "#\esc[1m") +(defconstant +unbold+ "#\esc[0m") +(defconstant +q+ #\") + +(defclass () ((name :accessor name) + (playing :reader playing :initform nil) + (password :accessor password))) +(defglobal *avatars* '()) + +(defglobal *write-avatars* nil) + +(defclass () ((g :reader g) + (socket :reader socket) + (parser :reader parser) + (avatar :reader avatar) + (curr-room :reader curr-room))) +(defglobal *connections* '()) + +(defconstant +port-number+ 6565) + +(defconstant +vd-type+ #(n s e w u d)) + +(defclass () ((name :reader name) + (desc :reader desc) + (exits :reader exits))) +(defglobal *rooms* '()) + +(defglobal *write-rooms* nil) + +(defconstant +command-type+ #(say help quit look + rooms make-room make-door teleport + n s e w + u d password shutdown)) + +(defconstant +name-prompt+ "Please enter your character name:") + +(defconstant +rdb+ "room.tam") +(defconstant +adb+ "avatar.tam") + +(defun first-substr (s) + ;; Return the first substring of s (delimited by a space). + (block result-first-substr + (do ((i 0 (+ i 1))) + ((>= i (length s)) s) + (if (char= (elt s i) #\space) + (return-from result-first-substr (subseq s 0 i)))))) + +(defun rest-substr (s) + ;; Return the second part of s. + (block result-rest-substr + (let ((b nil)) + (do ((i 0 (+ i 1))) + ((>= i (length s)) "") + (if (char= (elt s i) #\space) + (setq b t) + (if b + (return-from result-rest-substr (subseq s i (length s))))))))) + +(defun command (s) + (block result-command + (do ((i 0 (+ i 1))) + ((>= i (length +command-type+)) 'say) + (let ((c (elt +command-type+ i))) + (if (string= s (symbol-name c)) + (return-from result-command c)))))) + +(defun format-name (c) + (concatenate 'string +bold+ (name (avatar c)) +unbold+)) + +(defun say (c s) + (if (g c) + (format (socket c) "~A~%" s))) + +(defun broadcast (s) + (do ((cs *connections* (cdr cs))) + ((null cs)) + (let ((c (car cs))) + (say c s)))) + +(defun say (r s) + (do ((cs *connections* (cdr cs))) + ((null cs)) + (let ((c (car cs))) + (if (eq (curr-room c) r) + (say c s))))) + +(defun look (c) + (say c (concatenate 'string "Room: " (name (curr-room c)))) + (do ((ds (desc (curr-room c)) (cdr ds))) + ((null ds)) + (let ((d (car ds))) + (say c (line d)))) + (say c "") + (say c "Exits:") + (do ((i 0 (+ i 1))) + ((>= i (length +vd-type+))) + (let ((e (elt (exits (curr-room c)) i))) + (if (not (null e)) + (say c (concatenate 'string " " (symbol-name (elt +vd-type+ i)) " " (name e)))))) + (say c "Avatars:") + ()) + +;; TODO: Use the reader, for prototype at least? +;; Can switch to postmodern for production. +;; +;; Or dbm? +(defun read-room-database () + (setq *rooms* '()) + (with-open-input-file (file +rdb+) + (flet ((read-desc () + (let ((ls '())) + (do ((l (read-line file) (read-line file))) + ((string= l ".") ls) + (setq ls (cons l ls))))) + (skip-lines (n) + (do ((i 0 (+ i 1))) + ((> i n)) + (read-line file)))) + (do ((name (read-line file nil nil)) + (desc (read-desc))) + ((or (null name) (null desc))) + (skip-lines (length +vd-type+)) + (let ((r (make-instance (find-class ')))) + (setf (name r) name) + (setf (desc r) desc) + (setq *rooms* (cons r *rooms*)))) + (file-position file 0) + ()))) + +(defmethod print-object ((obj ) stream) + (flet ((write-desc (ds) + (mapcar (lambda (l) + (format stream "~A~%" l)) + ds)) + (write-exits (es) + (do ((i 0 (+ i 1))) + ((> i (length +vd-type+))) + (if (null (elt es) i) + (format stream "nil~%") + (format stream "~A~%" (name (elt es i))))))) + (format stream "~A~%" (name r)) + (write-desc (desc r)) + (format stream ".~%") + (write-exits (exits r)))) + +(defun write-room-database () + (with-open-output-file (file +rdb+) + (mapcar (lambda (r) (print-object r file)) *rooms*)) + (setq *write-rooms* nil)) + +(defun read-avatar-database () + (setq *avatars* '()) + (with-open-input-file (file +adb+) + (do ((name (read-line file nil nil)) + (password (read-line file nil nil))) + ((or (null name) (null password))) + (let ((a (make-instance (find-class ')))) + (setf (name a) name) + (setf (password a) password) + (setq *avatars* (cons a *avatars*))))) + (setq *write-avatars* nil)) + +(defmethod print-object ((obj ) stream) + (format stream "~A~%~A~%" (name a) (password a))) + +(defun write-avatar-database () + (with-open-output-file (file +adb+) + (mapcar (lambda (a) (print-object a file)) *avatars*))) + +(defun main () + (read-avatar-database) + (read-room-database) + (while (not *terminate-program*) + (check-for-inputs))) +(provide "cap-muck") diff --git a/dbm.lsp b/dbm.lsp new file mode 100644 index 0000000..52a0a27 --- /dev/null +++ b/dbm.lsp @@ -0,0 +1,27 @@ +;; No package, this is for eisl + +(c-include "") + +(defclass () (db :accessor db)) + +(defgeneric clearerr (self)) +(defmethod clearerr ((self )) + (flet ((clearerr-h (db) + (c-lang "dbm_clearerr(DB);"))) + (clearerr-h (db self)))) + +(defgeneric close (self)) + +(defgeneric delete (self key)) + +(defgeneric open (self openflags)) +(defmethod open ((self ) file openflags) + (flet ((open-h (file openflags) + (c-lang "res = dbm_open(FILE, OPENFLAGS, MODE);"))) + (setf (db self) (open-h file openflags)))) + +(defgeneric create (self openflags modes)) +(defmethod create ((self ) file openflags modes) + (flet ((open-h (file openflags modes) + (c-lang "res = dbm_open(FILE, OPENFLAGS, MODE);"))) + (setf (db self) (open-h file openflags modes)))) diff --git a/doc/breaking_rules.md b/doc/breaking_rules.md index 200f3b8..db4f28c 100644 --- a/doc/breaking_rules.md +++ b/doc/breaking_rules.md @@ -92,7 +92,8 @@ If absolutely necessary you can choose some of the libraries mentioned in the "P Even though this is a prototype, attention should be paid to basic craftsmanship. * Divide the system into packages, using the subset of CL that is - supported by OpenLisp + supported by OpenLisp. + This can start from just "section headers" with lots of semicolons. * Write docstrings for at least each public fun, class and package. There are good guidelines in the Elisp manual, but for now one sentence will suffice. * Use `declare` -- cgit 1.4.1-2-gfad0 From dbb7e6694c351ea0bd78d8405e5fe852f6de04b2 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Wed, 3 Feb 2021 00:00:50 +0000 Subject: ISLisp changes --- basic.lsp | 285 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- dbc2.lsp | 23 +++++ 2 files changed, 296 insertions(+), 12 deletions(-) create mode 100644 dbc2.lsp diff --git a/basic.lsp b/basic.lsp index 135c2ba..a63ab27 100644 --- a/basic.lsp +++ b/basic.lsp @@ -1,16 +1,278 @@ -#!/home/dbane/openlisp-11.0.0/uxlisp -shell +;;; BASIC interpreter -(require "abs-syn") -(require "lex") -(require "parsing") -(defpackage #:basic - (:use #:openlisp) - (:export - #:main)) -(in-package #:basic) +;;; Abstract syntax -;;; 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. +;; 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. + +(defclass () () (:abstractp t)) +(defclass () ((int :accessor int))) +(defclass () ((var :accessor var))) +(defclass () ((str :accessor str))) +(defclass () ((op :accessor op) (exp :accessor exp))) +(defclass () ((exp1 :accessor exp1) (op :accessor op) (exp2 :accessor exp2))) + +(defclass () () (:abstractp t)) +(defclass () ((rem :accessor rem))) +(defclass () ((goto :accessor goto))) +(defclass () ((expr :accessor expr))) +(defclass () ((var :accessor var))) +(defclass () ((expr :accessor expr) (num :accessor num))) +(defclass () ((var :accessor var) (expr :accessor expr))) + +(defclass () ((num :accessor num) (cmd :accessor cmd))) + +(defclass () () (:abstractp t)) +(defclass () ((line :accessor line))) +(defclass () ()) +(defclass () ()) +(defclass () ()) + +(defun priority-uop (unr-op) + (case unr-op + ((not) 1) + ((uminus) 7))) + +(defun priority-binop (bin-op) + (cond ((member bin-op '(mult div)) 6) + ((member bin-op '(plus minus)) 5) + ((eql bin-op 'mod) 4) + ((member bin-op '(equal less lesseq great greateq diff)) 3) + ((member bin-op '(and or)) 2))) + +;;; Program pretty printing +(defun pp-binop (bin-op) + (case bin-op + ((plus) "+") + ((mult) "*") + ((mod) "%") + ((minus) "-") + ((div) "/") + ((equal) " = ") + ((less) " < ") + ((lesseq) " <= ") + ((great) " > ") + ((greateq) " >= ") + ((diff) " <> ") + ((and) " & ") + ((or) " | "))) + +(defun pp-unrop (unr-op) + (case unr-op + ((uminus) "-") + ((not) "!"))) + +(defun parenthesis (x) + (string-append "(" x ")")) + +(defgeneric ppl (pr expr)) +(defmethod ppl (pr (expr )) + (convert (num expr) )) +(defmethod ppl (pr (expr )) + (var expr)) +(defmethod ppl (pr (expr )) + (string-append "\"" (str expr) "\"")) +(defmethod ppl (pr (expr )) + (let* ((op (op expr)) + (res-op (pp-unrop op)) + (pr2 (priority-uop op)) + (res-e (ppl pr2 (expr expr)))) + (if (= pr 0) + (parenthesis (string-append res-op res-e)) + (string-append res-op res-e)))) +(defmethod ppl (pr (expr )) + (let* ((op (op expr)) + (pr2 (priority-binop op)) + (res (string-append (ppl pr2 (expr1 expr)) (pp-binop op) (ppr pr2 (expr2 expr))))) + (if (>= pr2 pr) + res + (parenthesis res)))) + +(defgeneric ppr (pr expr)) +(defmethod ppr (pr (expr )) + (let* ((op (op expr)) + (pr2 (priority-binop op)) + (res (string-append (ppl pr2 (expr1 expr)) (pp-binop op) (ppr pr2 (expr2 expr))))) + (if (> pr2 pr) + res + (parenthesis res)))) +(defmethod ppr (pr (expr )) + (ppl pr expr)) +(defmethod ppr (pr (expr )) + (ppl pr expr)) +(defmethod ppr (pr (expr )) + (ppl pr expr)) +(defmethod ppr (pr (expr )) + (ppl pr expr)) + +(defun pp-expression (expr) + (ppl 0 expr)) + +(defgeneric pp-command (cmd)) +(defmethod pp-command ((cmd )) + (string-append "REM " (str cmd))) +(defmethod pp-command ((cmd )) + (string-append "GOTO " (convert (num cmd) ))) +(defmethod pp-command ((cmd )) + (string-append "PRNT " (pp-expression (expr cmd)))) +(defmethod pp-command ((cmd )) + (string-append "INPUT " (var cmd))) +(defmethod pp-command ((cmd )) + (string-append "IF " (pp-expression (expr cmd)) " THEN " (convert (num cmd) ))) +(defmethod pp-command ((cmd )) + (string-append "LET " (var cmd) " = " (pp-expression (expr cmd)))) + +(defun pp-line (l) + (string-append (convert (car l) ) " " (pp-command (cdr l)))) + +;;; Lexing +(defclass () () (:abstractp t)) +(defclass () ((int :reader int))) +(defclass () ((ident :reader ident))) +(defclass () ((lsymbol :reader lsymbol))) +(defclass () ((lstring :reader lstring))) +(defclass () ()) + +(defclass () ((string :initarg s :accessor string) + (current :initform 0 :accessor current) + (size :accessor size))) + +(defmethod initialize-object :after ((self ) initargs) + (setf (size self) (length (str self)))) + +(defgeneric forward (cl &rest args)) +(defmethod forward ((cl ) &rest args) + (let ((incr (if (null args) + 1 + (car args)))) + (setf (curr cl) (+ (curr cl) incr)))) + +(defgeneric extract (pred cl)) +(defmethod extract (pred (cl )) + (let* ((st (string cl)) + (pos (current cl)) + (ext (lambda (n) + (if (and (< n (size cl)) (pred (elt st n))) + (ext (+ n 1)) + n))) + (res (ext pos))) + (setf (current cl) res) + (subseq (string cl) pos (- res pos)))) + +(defgeneric extract-int (cl)) +(defmethod extract-int ((cl )) + (flet ((is-int (x) + (and (char>= x #\0) (char<= x #\9)))) + (convert (extract is-int cl) ))) + +(defgeneric extract-ident (cl)) +(defmethod extract-ident ((cl )) + (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))) + +;;; Parsing +(defclass () () (:abstractp t)) +(defclass () ((expr :accessor expr))) +(defclass () ((bin-op :accessor bin-op))) +(defclass () ((unr-op :accessor unr-op))) +(defclass () ()) + +(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 )) + (create (class ) 'n n 'c (parse-cmd cl))) + ((instancep tok (class )) + (cond ((string= (ident tok) "LIST") + (create (class ))) + ((string= (ident tok) "RUN") + (create (class ))) + ((string= (ident tok) "END") + (create (class ))) + (t (error "Parse error")))) + (t (error "Parse error"))))) + +;;; Evaluation +(defclass () () (:abstractp t)) +(defclass () ((int :accessor int))) +(defclass () ((str :accessor str))) +(defclass () ((bool :accessor bool))) + +(defclass () ((env :accessor env))) + +(defclass () ((line :reader line) + (xprog :reader xprog) + (xenv :reader xenv))) + +(defun runerr (n) + (throw 'run-error n)) + +;;;; Assembly +(defun lookup-index (tprog num-line) + (block result-lookup-index + (for ((i 0 (+ i 1))) + ((>= i (length tprog))) + (let ((num-i (num (elt tprog i)))) + (if (= num-i num-line) + (return-from result-lookup-index i) + (if (> num-i num-line) + (return-from result-lookup-index -1))))) + -1)) + +(defun assemble (prog) + (let ((tprog (apply #'vector prog))) + (for ((i 0 (+ i 1))) + ((>= i (length tprog))) + ()))) + +;;;; Expression evaluation +(defgeneric eval-exp (n envt expr)) +(defmethod eval-exp (n envt (expr )) + (create (class ) 'i (int expr))) +(defmethod eval-exp (n envt (expr )) + (case (op expr) + ((uminus) + (let ((result (eval-exp (exp expr)))) + (if (instancep result (class )) + (progn (setf (exp result) (- (exp result))) + result) + (runerr n)))) + ((not) + (let ((result (eval-exp (exp expr)))) + (if (instancep result (class )) + (progn (setf (exp result) (not (exp result))) + result) + (runerr n)))))) + +;;;; Command evaluation + +;;;; Program evaluation +(defun run (state) + +;;; Finishing touches + +;; 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) "> ") @@ -34,4 +296,3 @@ (format (standard-output) "> ") (catch 'error (one-command st))))) (format (standard-output) "See you later...~%")) -(provide "basic") diff --git a/dbc2.lsp b/dbc2.lsp new file mode 100644 index 0000000..477dc38 --- /dev/null +++ b/dbc2.lsp @@ -0,0 +1,23 @@ +(defmacro unless (test :rest body) + `(if (not ,test) (progn ,@body))) +;;(defun reduce (function sequence) +;; (let ((res 0)) +;; (for ((xs sequence (cdr xs))) +;; ((null xs) res) +;; (setq res (+ res (car xs)))))) +;;(reduce #'+ (map ' #'abs values)) +(defun sum (sequence) + (let ((res 0)) + (for ((xs sequence (cdr xs))) + ((null xs) res) + (setq res (+ res (car xs)))))) +(defun average-of-absolutes (values) + (the values) + (unless (> (length values) 0) + (error "average-of-absolutes requires non-null list" values)) + (let ((res (quotient (sum values) (length values)))) + (unless (>= res 0) + (error "average-of-absolutes must ensure positive result" res)) + (the res))) +;; (average-of-absolutes '(1 3)) +;; (average-of-absolutes '()) -- cgit 1.4.1-2-gfad0