100 lines
2.6 KiB
Common Lisp
100 lines
2.6 KiB
Common Lisp
;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO
|
|
;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO
|
|
;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO
|
|
|
|
(IN-PACKAGE :USER)
|
|
|
|
(DEFVAR *STATEMENT*)
|
|
|
|
;; C = comment
|
|
(DEFUN C (string)
|
|
(terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(princ "<Comment>")
|
|
; (dotimes (i 31) (princ "-"))
|
|
; (terpri)
|
|
(princ string)
|
|
; (terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(values))
|
|
|
|
;; R = read
|
|
(DEFMACRO R (statement)
|
|
(declare (special *statement*))
|
|
(setf *statement* statement)
|
|
`(progn
|
|
(terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(princ "<Lisp Statement>")
|
|
; (dotimes (i 29) (princ "-"))
|
|
; (terpri)
|
|
(pprint ',statement)
|
|
(terpri) ; (terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(values)))
|
|
|
|
(DEFUN STRIP-INITIAL-SPACES (st)
|
|
(let ((st2 (make-string (- (length st) (count #\Newline st)))))
|
|
(declare (type string st2))
|
|
(do ((i 0 (1+ i))
|
|
(j 0 (1+ j)))
|
|
((= i (length st)))
|
|
(let ((char (aref st i)))
|
|
(when (char= char #\newline)
|
|
(incf i))
|
|
(setf (aref st2 j) char)))
|
|
st2))
|
|
|
|
(DEFMACRO R2 (dstatement)
|
|
(declare (special *statement* *dstatement*))
|
|
(setf *dstatement* dstatement)
|
|
(setf *statement* (read-from-string dstatement))
|
|
`(progn
|
|
(terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(princ "<Lisp Statement>")
|
|
; (dotimes (i 31) (princ "-"))
|
|
; (terpri)
|
|
(princ (strip-initial-spaces *dstatement*))
|
|
; (terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(values)))
|
|
|
|
;; E = EXECUTE
|
|
(DEFUN E ()
|
|
(declare (special *statement*))
|
|
(terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(princ "<Result>")
|
|
; (dotimes (i 32) (princ "-"))
|
|
(terpri) ; (terpri)
|
|
(prin1 (eval *statement*))
|
|
(terpri) ; (terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(values))
|
|
|
|
(DEFUN EE ()
|
|
(declare (special *statement*))
|
|
(terpri)
|
|
(dotimes (i 10) (princ "-"))
|
|
(princ " Error ")
|
|
(dotimes (i 33) (princ "-"))
|
|
(terpri) (terpri)
|
|
(restart-case
|
|
(handler-bind ((error
|
|
#'(lambda (condition)
|
|
(format t "Type-error: ~S~&"
|
|
(class-name (class-of condition)))
|
|
(apply #'format t
|
|
(simple-condition-format-control condition)
|
|
(simple-condition-format-arguments condition))
|
|
(invoke-restart 'my-restart))))
|
|
(eval *statement*))
|
|
(my-restart () (values)))
|
|
(terpri) (terpri)
|
|
(dotimes (i 50) (princ "-"))
|
|
(values))
|
|
|
|
(DEFMACRO M (statement)
|
|
(eval statement)
|
|
'(values )) |