BSD 4 release

[unix-history] / usr / src / cmd / liszt / camacs.l

;----------- macros for the compiler -------------


(setq sectioncamacsid "@(#)camacs.l     5.2     11/11/80")  ; id for SCCS

; Copyright (c) 1980 ,  The Regents of the University of California.
; All rights reserved.  
; author: j. foderaro

(declare (macros t))                    ; compile and save macros

;--- comp-err
;    comp-warn
;    comp-note
;    comp-gerr
; these are the compiler message producing macros.  The form is
; (comp-xxxx val1 val2 val3 ... valn) , all values are printed according
;  to this scheme. If vali is an atom, it is patomed, if vali is a
;  list, it is evaluated and printed. If vali is N a newline is printed
; 
; furthermore
;    the name of the current function is printed first
;    after comp-err prints the message, it does a throw to Comp-err .
;    errors are preceeded by Error: 
;       warnings by %Warning: and
;       notes by %Note:
;     The message is sent to the message file
;
(def comp-err
 (macro (l)
        `(progn ,@(comp-msg 
                            `( "Error: "  g-fname ": " ,@(cdr l) N))
                (setq er-fatal (1+ er-fatal))
                (throw nil Comp-error))))

(def comp-warn
 (macro (l)
        `(progn (cond (fl-warn 
                       ,@(comp-msg
                            `( "%Warning: "  g-fname ": " ,@(cdr l) N)))))))

(def comp-note
 (macro (l)
        `(progn (cond (fl-verb
                       ,@(comp-msg
                            `( "%Note: "  ,@(cdr l) N)))))))

(def comp-gerr
 (macro (l)
        `(progn ,@(comp-msg
                       `("?Error: " ,@(cdr l) N)) 
                (setq er-fatal (1+ er-fatal)))))

;--- comp-msg - port
;             - lst
;  prints the lst to the given port.  The lst is printed in the manner
; described above, that is atoms are patomed, and lists are evaluated
; and printed, and N prints a newline.   The output is always drained.
;
(eval-when (compile load eval)
 (def comp-msg
      (lambda (lis)
              (cond ((null lis) `((drain)))
                    (t `(,(cond ((atom (car lis))
                                 (cond ((eq (car lis) 'N)
                                        `(terpr))
                                       (t `(niceprint ,(car lis)))))
                                (t `(niceprint ,(car lis))))
                          ,@(comp-msg (cdr lis)))))))
 (def niceprint
      (macro (l)
             `((lambda (val)
                       (cond ((floatp val) 
                              (patom (quotient (fix (times val 100)) 100.0)))
                             (t (patom val))))
               ,(cadr l)))))

;--- super if macro
(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)))

;--- standard push macro
; (Push stackname valuetoadd)

(defmacro Push (atm val)
 `(setq ,atm (cons ,val ,atm)))

;--- pop macro

(defmacro Pop (val)
 `(prog1 (car ,val) (setq ,val (cdr ,val))))

;--- unpush macro - like pop except top value is thrown away
(defmacro unpush (atm)
 `(setq ,atm (cdr ,atm)))

;--- and an increment macro

(defmacro incr (atm)
 `(setq ,atm (1+ ,atm)))

(defmacro decr (atm)
 `(setq ,atm (1- ,atm)))
;--- add a comment

(defmacro makecomment (arg)
 `(cond (fl-comments (setq g-comments (cons ,arg g-comments)))))

;--- add a comment irregardless of the fl-comments flag
(defmacro forcecomment (arg)
 `(setq g-comments (cons ,arg g-comments)))

;--- write to the .s file

(defmacro sfilewrite (arg)
 `(patom ,arg vp-sfile))