![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to camacs.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / liszt|
Return to camacs.l CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / liszt |
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.