4BSD/usr/lib/lisp/jkfmacs.l

(setq SCCS-jkfmacs "@(#)jkfmacs.l	1.2	10/13/80")

;------ jkfmacs :: common and useful macros
;
(declare (macros t))

; contents: 
;	If macro
;


;--- super if macro
; This macro allow the following forms:
;	(If a then b)   ==>  (cond (a b))
;	(If a thenret)  ==>  (cond (a))
;	(If a then b else c) ==> (cond (a b) (t c))
;	(If a then b b2 	     ==> (cond (a b b2) (c d d2) (t e))
;	 elseif c then d d2
;	 else e)
;
;
(defun If macro  (lis) 
       (prog (majlis minlis revl)
	     (do ((revl (reverse lis) (cdr revl)))
		 ((null revl))
		 (cond ((eq (car revl) 'else)
			(setq majlis `((t ,@minlis) ,@majlis)
			      minlis nil))
		       ((or (eq (car revl) 'then) (eq (car revl) 'thenret))
			(setq revl (cdr revl)
			      majlis `((,(car revl) ,@minlis) ,@majlis)
			      minlis nil))
		       ((eq (car revl) 'elseif))
		       ((eq (car revl) 'If)
			(setq majlis `(cond ,@majlis)))
		       (t (setq minlis `( ,(car revl) ,@minlis)))))
	     ; we displace the previous macro, that is we actually replace
	     ; the if list structure with the corresponding cond, meaning
	     ; that the expansion is done only once
	     (rplaca  lis (car majlis))
	     (rplacd lis (cdr majlis))
	     (return majlis)))

;--- msg : print a message consisting of strings and values
; arguments are:
;   N	    - print a newline
;   (N foo) - print foo newlines (foo is evaluated)
;   B       - print a blank
;   (B foo) - print foo blanks (foo is evaluated)
;   (P foo) - print following args to port foo (foo is evaluated)
;   other   - evaluate a princ the result (remember strings eval to themselves)

(defmacro msg (&rest msglist)
  (do ((ll msglist (cdr ll))
       (result)
       (cur nil nil)
       (curport nil)
       (current))
      ((null ll) `(progn ,@(nreverse result)))
      (setq current (car ll))
      (If (dtpr current)
	  then (If (eq (car current) 'N)
		   then (setq cur `(msg-tyo-char 10 ,(cadr current)))
		elseif (eq (car current) 'B)
		   then (setq cur `(msg-tyo-char 32 ,(cadr current)))
		elseif (eq (car current) 'P)
		   then (setq curport (cadr current))
		else (setq cur `(princ ,current)))
       elseif (eq current 'N)
	  then (setq cur (list 'tyo 10))	; (can't use backquote
       elseif (eq current 'B)			; since must have new
      	  then (setq cur (list 'tyo 32))	; dtpr cell at end)
       else (setq cur `(princ ,current)))
      (If cur 
	  then (setq result (cons (If curport then (nconc cur (ncons curport))
			                      else cur)
				  result)))))

(defun msg-tyo-char (ch n)
  (do ((i n (1- n)))
      ((< n 1))
      (tyo ch)))



;--- standard push, unpush and pop macros
;
(defmacro push (stack value)
  `(setq ,stack (cons ,value ,stack)))

(defmacro unpush (stack)
  `(setq ,stack (cdr ,stack)))

(defmacro pop (stack)
  `(prog1 (car stack) (setq ,stack (cdr ,stack))))



(putprop 'jkfmacs 1 'version)