Return to camacs.l CVS log

Up to [CSRG BSD Unix] / 40BSD / cmd / liszt

Annotation of 40BSD/cmd/liszt/camacs.l, revision 1.1

1.1     ! root        1: 
        !             2: ;----------- macros for the compiler -------------
        !             3: 
        !             4: 
        !             5: (setq sectioncamacsid "@(#)camacs.l    5.2     11/11/80")  ; id for SCCS
        !             6: 
        !             7: ; Copyright (c) 1980 ,  The Regents of the University of California.
        !             8: ; All rights reserved.  
        !             9: ; author: j. foderaro
        !            10: 
        !            11: (declare (macros t))                   ; compile and save macros
        !            12: 
        !            13: ;--- comp-err
        !            14: ;    comp-warn
        !            15: ;    comp-note
        !            16: ;    comp-gerr
        !            17: ; these are the compiler message producing macros.  The form is
        !            18: ; (comp-xxxx val1 val2 val3 ... valn) , all values are printed according
        !            19: ;  to this scheme. If vali is an atom, it is patomed, if vali is a
        !            20: ;  list, it is evaluated and printed. If vali is N a newline is printed
        !            21: ; 
        !            22: ; furthermore
        !            23: ;    the name of the current function is printed first
        !            24: ;    after comp-err prints the message, it does a throw to Comp-err .
        !            25: ;    errors are preceeded by Error: 
        !            26: ;      warnings by %Warning: and
        !            27: ;      notes by %Note:
        !            28: ;     The message is sent to the message file
        !            29: ;
        !            30: (def comp-err
        !            31:   (macro (l)
        !            32:         `(progn ,@(comp-msg 
        !            33:                             `( "Error: "  g-fname ": " ,@(cdr l) N))
        !            34:                 (setq er-fatal (1+ er-fatal))
        !            35:                 (throw nil Comp-error))))
        !            36: 
        !            37: (def comp-warn
        !            38:   (macro (l)
        !            39:         `(progn (cond (fl-warn 
        !            40:                        ,@(comp-msg
        !            41:                             `( "%Warning: "  g-fname ": " ,@(cdr l) N)))))))
        !            42: 
        !            43: (def comp-note
        !            44:   (macro (l)
        !            45:         `(progn (cond (fl-verb
        !            46:                        ,@(comp-msg
        !            47:                             `( "%Note: "  ,@(cdr l) N)))))))
        !            48: 
        !            49: (def comp-gerr
        !            50:   (macro (l)
        !            51:         `(progn ,@(comp-msg
        !            52:                        `("?Error: " ,@(cdr l) N)) 
        !            53:                 (setq er-fatal (1+ er-fatal)))))
        !            54: 
        !            55: ;--- comp-msg - port
        !            56: ;            - lst
        !            57: ;  prints the lst to the given port.  The lst is printed in the manner
        !            58: ; described above, that is atoms are patomed, and lists are evaluated
        !            59: ; and printed, and N prints a newline.   The output is always drained.
        !            60: ;
        !            61: (eval-when (compile load eval)
        !            62:   (def comp-msg
        !            63:        (lambda (lis)
        !            64:               (cond ((null lis) `((drain)))
        !            65:                     (t `(,(cond ((atom (car lis))
        !            66:                                  (cond ((eq (car lis) 'N)
        !            67:                                         `(terpr))
        !            68:                                        (t `(niceprint ,(car lis)))))
        !            69:                                 (t `(niceprint ,(car lis))))
        !            70:                           ,@(comp-msg (cdr lis)))))))
        !            71:   (def niceprint
        !            72:        (macro (l)
        !            73:              `((lambda (val)
        !            74:                        (cond ((floatp val) 
        !            75:                               (patom (quotient (fix (times val 100)) 100.0)))
        !            76:                              (t (patom val))))
        !            77:                ,(cadr l)))))
        !            78: 
        !            79: ;--- super if macro
        !            80: (defun If macro  (lis) 
        !            81:        (prog (majlis minlis revl)
        !            82:             (do ((revl (reverse lis) (cdr revl)))
        !            83:                 ((null revl))
        !            84:                 (cond ((eq (car revl) 'else)
        !            85:                        (setq majlis `((t ,@minlis) ,@majlis)
        !            86:                              minlis nil))
        !            87:                       ((or (eq (car revl) 'then) (eq (car revl) 'thenret))
        !            88:                        (setq revl (cdr revl)
        !            89:                              majlis `((,(car revl) ,@minlis) ,@majlis)
        !            90:                              minlis nil))
        !            91:                       ((eq (car revl) 'elseif))
        !            92:                       ((eq (car revl) 'If)
        !            93:                        (setq majlis `(cond ,@majlis)))
        !            94:                       (t (setq minlis `( ,(car revl) ,@minlis)))))
        !            95:             ; we displace the previous macro, that is we actually replace
        !            96:             ; the if list structure with the corresponding cond, meaning
        !            97:             ; that the expansion is done only once
        !            98:             (rplaca  lis (car majlis))
        !            99:             (rplacd lis (cdr majlis))
        !           100:             (return majlis)))
        !           101: 
        !           102: ;--- standard push macro
        !           103: ; (Push stackname valuetoadd)
        !           104: 
        !           105: (defmacro Push (atm val)
        !           106:   `(setq ,atm (cons ,val ,atm)))
        !           107: 
        !           108: ;--- pop macro
        !           109: 
        !           110: (defmacro Pop (val)
        !           111:   `(prog1 (car ,val) (setq ,val (cdr ,val))))
        !           112: 
        !           113: ;--- unpush macro - like pop except top value is thrown away
        !           114: (defmacro unpush (atm)
        !           115:   `(setq ,atm (cdr ,atm)))
        !           116: 
        !           117: ;--- and an increment macro
        !           118: 
        !           119: (defmacro incr (atm)
        !           120:   `(setq ,atm (1+ ,atm)))
        !           121: 
        !           122: (defmacro decr (atm)
        !           123:   `(setq ,atm (1- ,atm)))
        !           124: ;--- add a comment
        !           125: 
        !           126: (defmacro makecomment (arg)
        !           127:   `(cond (fl-comments (setq g-comments (cons ,arg g-comments)))))
        !           128: 
        !           129: ;--- add a comment irregardless of the fl-comments flag
        !           130: (defmacro forcecomment (arg)
        !           131:   `(setq g-comments (cons ,arg g-comments)))
        !           132: 
        !           133: ;--- write to the .s file
        !           134: 
        !           135: (defmacro sfilewrite (arg)
        !           136:   `(patom ,arg vp-sfile))
        !           137: 
        !           138: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.