diff options
| -rw-r--r-- | basic.lsp | 218 | ||||
| -rwxr-xr-x | btech.lsp | 45 | ||||
| -rw-r--r-- | cap-muck.lsp | 2 |
3 files changed, 158 insertions, 107 deletions
diff --git a/basic.lsp b/basic.lsp index 5209832..a355ed0 100644 --- a/basic.lsp +++ b/basic.lsp @@ -13,12 +13,12 @@ (defclass <exp-bin> (<expression>) ((exp1 :accessor exp1) (op :accessor op) (exp2 :accessor exp2))) (defclass <command> () () (:abstractp t)) -(defclass <cmd-rem> (<command>) ((rem :accessor rem))) -(defclass <cmd-goto> (<command>) ((goto :accessor goto))) +(defclass <cmd-rem> (<command>) ((rem :initarg r :accessor rem))) +(defclass <cmd-goto> (<command>) ((goto :initarg g :accessor goto))) (defclass <cmd-print> (<command>) ((expr :accessor expr))) -(defclass <cmd-input> (<command>) ((var :accessor var))) -(defclass <cmd-if> (<command>) ((expr :accessor expr) (num :accessor num))) -(defclass <cmd-let> (<command>) ((var :accessor var) (expr :accessor expr))) +(defclass <cmd-input> (<command>) ((var :initarg v :accessor var))) +(defclass <cmd-if> (<command>) ((expr :initarg e :accessor expr) (num :initarg n :accessor num))) +(defclass <cmd-let> (<command>) ((var :initarg v :accessor var) (expr :initarg e :accessor expr))) (defclass <line> () ((num :accessor num) (cmd :accessor cmd))) @@ -29,33 +29,33 @@ (defclass <phrase-p-end> (<phrase>) ()) (defun priority-uop (unr-op) - (case unr-op - ((not) 1) - ((uminus) 7))) + (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))) + (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) " | "))) + (case bin-op + ((plus) "+") + ((mult) "*") + ((mod) "%") + ((minus) "-") + ((div) "/") + ((equal) " = ") + ((less) " < ") + ((lesseq) " <= ") + ((great) " > ") + ((greateq) " >= ") + ((diff) " <> ") + ((and) " & ") + ((or) " | "))) (defun pp-unrop (unr-op) (case unr-op @@ -156,8 +156,8 @@ (let* ((st (string cl)) (pos (current cl)) (res (ext pos))) - (setf (current cl) res) - (subseq (string cl) pos (- res pos))))) + (setf (current cl) res) + (subseq (string cl) pos (- res pos))))) ;; Some functions from C's ctype.h: (defun isdigit (c) @@ -197,11 +197,11 @@ res)) ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\))) (forward cl) - (create (class <lsymbol>) 's c)) + (create (class <lsymbol>) 's (create-string 1 c))) ((or (char= c #\<) (char= c #\>)) (forward cl) (if (>= (current cl) (size cl)) - (crate (class <lsymbols>) 's c) + (crate (class <lsymbol>) 's (create-string 1 c)) (let ((cs (elt (string cl) (current cl)))) (cond ((and (char= c #\<) (char= cs #\=)) (forward cl) @@ -213,7 +213,7 @@ (forward cl) (create (class <lsymbol>) 's "<>")) (t - (create (class <lsymbol>) c)))))) + (create (class <lsymbol>) 's (create-string 1 c))))))) (t (error "Lexer error"))))) (if (>= (current cl) (size cl)) (create (class <lend>)) @@ -222,48 +222,110 @@ ;;; Parsing (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-bin> (<exp-elem>) ((bin-op :initarg o :accessor bin-op))) +(defclass <elem-unr> (<exp-elem>) ((unr-op :initarg o :accessor unr-op))) (defclass <elem-lp> (<exp-elem>) ()) (defun unr-symb (s) - (cond ((string= s "!") 'not) - ((string= s "-") 'uminus) - (t (throw 'parse-failure)))) + (case-using #'string= s + (("!") 'not) + (("-") '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) - ((string= s ">=") 'greateq) - ((string= s "<>") 'diff) - ((string= s "&") 'and) - ((string= s "|") 'or) - (t (throw 'parse-failure)))) + (case-using #'string= s + (("+") 'plus) + (("-") 'minus) + (("*") 'mult) + (("/") 'div) + (("%") 'mod) + (("=") 'equal) + (("<") 'less) + (("<=") 'lesseq) + ((">") 'great) + ((">=") 'greateq) + (("<>") 'diff) + (("&") 'and) + (("|") 'or) + (t nil))) (defun tsymb (s) - (catch 'parse-failure (lambda + (let ((maybe-bin (bin-symb s))) + (if (null maybe-bin) + (create (class <elem-unr>) 'o (unr-symb s)) + (create (class <elem-bin>) 'o maybe-bin)))) + +(defun reduce (pr) + ) + +(defun stack-or-reduce (lex stack) + ) + +(defun reduce-all (st) + (cond ((null st) (error "Parse error")) + ((and (= (length st) 1) (instancep (car st) (class <elem-exp>))) (expr (car st))) + (t (reduce-all (reduce 0 st))))) + +(defun parse-exp (stop cl) + (let ((p 0)) + (flet ((parse-one (stack) + (setq p (current cl)) + (let ((l (lexer cl))) + (if (not (stop l)) + (parse-one (stack-or-reduce l stack)) + (progn (setf (current cl) p) + (reduce-all stack)))))) + (parse-one '())))) + +(defun parse-cmd (cl) + (let ((tok (lexer cl))) + (if (instancep tok (class <lident>)) + (case-using #'string= (ident tok) + (("REM") + (create (class <cmd-rem>) 'r (extract (lambda (x) t) cl))) + (("GOTO") + (create (class <cmd-goto>) 'g (let ((tok (lexer cl))) + (if (instancep tok (class <lint>)) + (int tok) + (error "Parse error"))))) + (("INPUT") + (create (class <cmd-input>) 'v (let ((tok (lexer cl))) + (if (instancep tok (class <lident>)) + (ident tok) + (error "Parse error"))))) + (("PRINT") + (create (class <cmd-print>) 'e (parse-exp (lambda (x) (instancep x (class <lend>))) cl))) + (("LET") + (let ((l2 (lexer cl)) + (l3 (lexer cl))) + (if (and (instancep l2 (class <lident>)) (instancep l3 (class <lsymbol>)) (string= (lsymbol l3) "=")) + (create (class <cmd-let>) 'v (ident l2) 'e (parse-exp (lambda (x) (instancep x <lend>)) cl)) + (error "Parse error")))) + (("IF") + (let ((test (parse-exp (lambda (x) (and (instancep x <lident>) (string= (ident x) "THEN"))) cl))) + (progn (lexer cl) + (let ((tok (lexer cl))) + (if (instancep tok (class <lint>)) + (create (class <cmd-if>) 'e test 'n (int tok)) + (error "Parse error")))))) + (t (error "Parse error"))) + (error "Parse error")))) (defun parse (str) - (let* ((cl (init-lex str)) - (tok (lexer cl))) - (cond ((instancep tok (class <lint>)) - (create (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"))))) + (let* ((cl (init-lex str)) + (tok (lexer cl))) + (cond ((instancep tok (class <lint>)) + (create (class <line>) 'n n 'c (parse-cmd cl))) + ((instancep tok (class <lident>)) + (case-using #'string= (ident tok) + (("LIST") + (create (class <phrase-list>))) + (("RUN") + (create (class <phrase-run>))) + (("END") + (create (class <phrase-p-end>))) + (t (error "Parse error")))) + (t (error "Parse error"))))) ;;; Evaluation (defclass <value> () () (:abstractp t)) @@ -282,21 +344,21 @@ ;;;; 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)) + (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))) - ()))) + (let ((tprog (apply #'vector prog))) + (for ((i 0 (+ i 1))) + ((>= i (length tprog))) + ()))) ;;;; Expression evaluation (defgeneric eval-exp (n envt expr)) diff --git a/btech.lsp b/btech.lsp index 5a4d11b..07b0d48 100755 --- a/btech.lsp +++ b/btech.lsp @@ -1,27 +1,18 @@ -#!/home/dbane/openlisp-10.9.0/uxlisp -shell -;;; ISLisp is fine so long as you do "read-line" from the same place you call the entry point fun. -;;; So -shell with an immediate call doesn't work, something is closed after reading the Lisp source. -;;; -shell -keep, supplying the call from the keyboard works fine. -;;; -;;; Calling entry point from a Lisp CLI (after "load") also works. -;;; And this may be what I end up with, if I'm doing a view in Emacs. -(require "cmd") -(require "builtins") -(defpackage #:btech - (:use #:cmd #:builtins) - (:export - #:main)) -(in-package #:btech) -;; Favour symbols & objects over C-like numbers -(defconstant +cmds+ (list - (create-tab #'bt-quit "QUIT" 1) - (create-tab #'help "help" 2) - (create-tab #'look "look" 2))) -(defun main () - (read-line) ; Throw away LF - (format (standard-output) "> ") - (let* ((tab (lookup (parse (read-line)) +cmds+)) - (f (fun tab))) - (funcall f))) ; I *think* this is better than (flet ... -(provide "btech") -(main) +(defclass <unit> () ((name :initarg n :reader name) + (tp :initarg tp :reader tp) + (pv :initarg p :reader pv))) +(defconstant +mad-3r+ (create (class <unit>) + 'n 'marauder + 'tp 'bm + 'p 42 + 'sz 3 + 'tmm 1 + 'mv 8 + 'role 'sniper + 'skill 3 + 'damage #(2 3 3) + 'ov 1 + 'a 0 + 's 0 + 'crit + 'id)) diff --git a/cap-muck.lsp b/cap-muck.lsp index 36bffba..54bfa9a 100644 --- a/cap-muck.lsp +++ b/cap-muck.lsp @@ -183,5 +183,3 @@ (while (not *terminate-program*) (check-for-inputs))) (main) - - |