;;; Lisp macros (variously hacked by RLB and JLK) (eval-when (eval compile) (setq defmacro-check-args ())) (defun /#macro () (let ((c (ascii (tyipeek))) b a) (setq a (caseq c (// (tyi) (readch)) ;#/char returns SCO for char (/, (tyi) (eval (read))) ;#,(form) returns eval of form ;can't - QUOTE (/( (read)) ;simulate NIL #(..) vectors ((/t T) (tyi) 'T) ;truthity (Q (tyi) ;#Qnum reads in octal (let ((ibase 8.)) (read))) (X (tyi) ;#Xnum reads in hex (let ((ibase 16.)) (read))) (^ (tyi) (boole 1 37 (tyi))) ;#^A returns 1 (= (tyi) (cond ((= (tyipeek) 47.) ; #=/x returns code for x (tyi) (tyi)) ((ascii (read))))) ;#=num returns SCO num (T (setq b 'T)))) (cond (b (let ((args c)) (break |Random after /#| 'T))) (a)))) ;;; (/@ . body) just substitutes for ;;; in (PROGN . ) -- useful for e.g.: ;;; (/@ x (arraycall fixnum barfa (1+ i)) (store x (1+ x))) (defun (/@ macro) (form) (let (((abbrev expan . body) (cdr form))) `(progn .,(subst expan abbrev body)))) ;;; (*PUSH symbol cruft) does (PUSH cruft symbol) ;; ;but looks nicer when there is a lot of cruft. (defun (*push macro) (x) `(push ,(caddr x) ,(cadr x))) ;;; Add an element to a list non-redundantly (defun (addl macro) (form) (let (((() item list) form)) `(if (not (memq ,item ,list)) (setq ,list (cons ,item ,list))))) ;;; The >=, <=, and NOT= macros extend Lisp's subrs. (defun (/>= macro) (x) (|<=> ify| (cdr x) '/<)) (defun (/<= macro) (x) (|<=> ify| (cdr x) '/>)) (defun |<=> ify| (body pred) (caseq (length body) (0 '(progn 'T)) (1 `(progn ,(car body) 'T)) (2 `(not (,pred .,body))) (T (do ((body body (cdr body)) (l)) ((null (cdr body)) `(and .,(nreverse l))) (push `(not (,pred ,(car body) ,(cadr body))) l))))) (defun (not= macro) (x) `(not (= ,(cadr x) ,(caddr x)))) ;;; Variants of COND ;;; (WHEN . ) evaluates when is non-nil. (defun (when macro) (x) `(cond (,(cadr x) . ,(cddr x)))) ;;; (UNLESS . ) evaluates unless is non-nil. (defun (unless macro) (x) `(cond ((not ,(cadr x)) . ,(cddr x)))) ;;; (IF ;;; ...) This is the standard grinding. (defun (if macro) (x) (cond ((null (cdddr x)) `(cond (,(cadr x) ,(caddr x)))) (t `(cond (,(cadr x) ,(caddr x)) (t . ,(cdddr x)))))) ;Self QUoting Internal Datum - if interpreted, like eval first time only, ;thereafter, quoted. If compiled and then fasloaded, it gets evaled ;at fasload time. (declare (special squid)) (defun (squid macro) (x) (cond (compiler-state (rplaca x squid)) ;Can't figure out EVAL-WHEN ((rplaca x 'quote) (rplaca (cdr x) (eval (cadr x))) x))) ;;; Macros for copying list structure (from MRG originally) (defun (copy macro) (x) `(subst nil nil ,(cadr x))) (defun (copyp macro) (x) `(cons (car ,(cadr x)) (cdr ,(cadr x)))) (defun (copyl macro) (x) `(append ,(cadr x) nil)) ;;; Macro for initializing special variables if unbound at load time (defun (special-init macro) (x) `(if (not (boundp ',(cadr x))) (setq ,(cadr x) ,(caddr x)))) ;;; print beginning at left margin (defun (princ0 macro) (x) `(progn (if (not (= 0 (cdr (cursorpos .,(cddr x))))) (terpri .,(cddr x))) (princ .,(cdr x)))) ;;; Append n strings together (defun (string-append macro) (x) `(maknam (mapcan 'explodec (list .,(cdr x))))) ;;; VALRET several strings quitely (defun (valret* macro) (x) `(let ((tty-return)) (valret (string-append .,(cdr x))))) ;;; Flush LSPMAC from the enviroment (defun cleanup-lspmac fexpr (x) (when (null x) (setq x '(chmac macro))) (when (memq 'chmac x) (do l '(/# /& /!) (cdr l) (null l) (setsyntax (car l) 'macro nil))) (when (memq 'macro x) (do l '(/@ lambind progb seqlam catch* throw* /<= />= not= when unless squid if file-length *push copy copyl copyp special-init princ0 string-append valret*) (cdr l) (null l) (remprop (car l) 'macro))) (remprop 'cleanup-lspmac 'expr) (sstatus nofeature lspmac)) (sstatus feature lspmac) ;; Local Modes: ;; Mode: LISP ;; Comment Col: 40 ;; END: