1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PC:WDECLARE.SL 4% Title: Extended WDECLARE for non-kernel 5% Author: M. L. Griss 6% Created: May 1983 7% Modified: 06-Dec-83 10:00 (Brian Beach) 8% Status: Open Source: BSD License 9% Mode: Lisp 10% Package: Compiler 11% 12% (c) Copyright 1983, Hewlett-Packard Company, see the file 13% HP_disclaimer at the root of the PSL file tree 14% 15% Redistribution and use in source and binary forms, with or without 16% modification, are permitted provided that the following conditions are met: 17% 18% * Redistributions of source code must retain the relevant copyright 19% notice, this list of conditions and the following disclaimer. 20% * Redistributions in binary form must reproduce the above copyright 21% notice, this list of conditions and the following disclaimer in the 22% documentation and/or other materials provided with the distribution. 23% 24% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 25% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 26% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 27% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 28% CONTRIBUTORS 29% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 30% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 31% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 32% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 34% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35% POSSIBILITY OF SUCH DAMAGE. 36% 37% 38%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 39% 40% Revisions: 41% 42% 7 Mar 1984 1425-PST (Nancy Kendzierski) 43% Changed warnings to StdError in NKWCONSTReform. 44% 06-Dec-83 10:00 (Brian Beach) 45% Translated from Rlisp to Lisp. 46% 47%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 48 49% if either UpperBound or Initializer are NIL, they are considered to be 50% unspecified. 51 52(fluid '(locallabels*)) 53(off kernelmode) 54 55(de registernameP (x) nil) 56% In case try to access registername 57 58 59(df wdeclare (U) 60 (foreach x in (cddr U) do (WDeclare1 (car x) (car U) (cadr U) (cadr x) (caddr x)))) 61 62(flag '(wdeclare) 'IGNORE) 63 64(de WDeclare1 (Name Scope typ UpperBound Initializer) 65 (PROG (Base) 66 (COND ((or (get Name 'wconst) (get Name 'wvar) 67 (get Name 'wstring) (get Name 'Warray)) 68 (PROGN 69 (ErrorPrintF "*** %w declared twice, second declaration ignored.%n" 70 Name) 71 (return nil) nil))) 72 73 (COND ((Equal typ 'wconst) 74 (return (COND ((and (Equal Scope 'external) (not (get Name 'wconst))) 75 (ErrorPrintF "*** A value has not been defined for WConst %r" 76 Name)) (t 77 78 (PROGN (put Name 'Scope (COND ((Equal Scope 'EXPORTED) 'external) (t Scope))) 79 (put Name 'wconst (NKWCONSTReform Initializer)))))))) 80 (COND ((registernameP Name) 81 (return (ErrorPrintF " Cant reference a register in WDECLARE %r" Name)))) 82 (COND ((Equal Scope 'external) 83 % Need some more error checking to be sure exists at this point 84 (return (COND ((Numberp (get Name typ)) (put Name 'Scope 'external)) (t 85 (ErrorPrintF " %r has no current value in WDECLARE" Name)))))) 86 % Here need to try RUN-TIME Lookup 87 (put Name typ Name) 88 (put Name 'Scope (COND ((Equal Scope 'EXPORTED) 'external) (t Scope))) 89 (return (WarrayAlloc Name 90 typ 91 UpperBound 92 Initializer)))) 93 94 95(de WarrayAlloc (Name typ UpperBound Initializer) 96 (PROG (Base Nwrds) 97 (COND ((Equal typ 'wvar) 98 (return (PROGN (COND (UpperBound 99 (ErrorPrintF "*** An UpperBound may not be specified for a WVar"))) 100 (SETQ Initializer (COND (Initializer (NKWCONSTReform Initializer)) (t 0))) 101 102 (SETQ Base (GtWarray 1)) 103 (PutMem Base Initializer) 104 (put Name 'wvar Base) 105 Base)))) 106 (COND ((and UpperBound Initializer) 107 (ErrorPrintF "*** Can't have both UpperBound and initializer")) 108 ((not (or UpperBound Initializer)) 109 (ErrorPrintF "*** Must have either UpperBound or initializer")) 110 (UpperBound 111 (return (PROGN (SETQ UpperBound (NKWCONSTReform UpperBound)) 112 (COND ((Equal typ 'Warray) (SETQ Nwrds (Plus UpperBound 1))) (t 113 (SETQ Nwrds (Strpack (Plus UpperBound 1))))) 114 (SETQ Base (GtWarray Nwrds)) 115 (put Name typ Base) 116 (put Name 'wconst Base) % Seems a KLUDGE, someone converts 117 Base)))) 118 (SETQ Initializer (COND ((StringP Initializer) (String2List Initializer)) (t 119 (NKWCONSTReformLis Initializer)))) 120 (SETQ Nwrds (Length Initializer)) 121 (COND ((Equal typ 'Warray) (PROGN (SETQ Base (GtWarray (Plus Nwrds 1))) 122 (put Name typ Base) 123 (put Name 'wconst Base) 124 (foreach x in Initializer do 125 (PROGN (PutMem Base x) 126 (SETQ Base (Plus Base AddressingUnitsPerItem)))))) (t 127 (PROGN (SETQ Base (GtWarray (Strpack (Plus Nwrds 1)))) 128 (PutMem Base Nwrds) % String Length 129 (put Name typ Base) 130 (put Name 'wconst Base) 131 (for (from i 0 Nwrds 1) (do 132 (PROGN (setf (strbyt Base i) (car Initializer)) 133 (SETQ Initializer (cdr Initializer)))))))))) 134 135 136 137(de NKWCONSTReform (U) 138(PROG (x) 139 (return (COND ((or (FixP U) (StringP U)) U) 140 ((IDP U) 141 (COND ((SETQ x (get U 'Warray)) x) 142 ((SETQ x (get U 'wstring)) x) 143 ((SETQ x (get U 'wvar)) (GetMem x)) 144 ((SETQ x (get U 'wconst)) x) (t 145 (StdError (bldmsg "Unknown symbol %r in NKWCONSTReform" U))))) 146 ((PairP U) 147 (COND ((SETQ x (get (car U) 'NKWCONSTReformPseudo)) (Apply x (list U))) 148 ((SETQ x (get (car U) 'DOFN)) (cons x (NKWCONSTReformLis (cdr U)))) 149 ((MacroP (car U)) (NKWCONSTReform (Apply (cdr (GetD (car U))) (list U)))) (t 150 (cons (car U) (NKWCONSTReformLis (cdr U)))))) (t 151 (StdError (bldmsg "Illegal expression %r in NKWCONSTReform" U))))))) 152 153 154(de NKWCONSTReformIdent (U) 155 U) 156 157(put 'InternalEntry 'NKWCONSTReformPseudo 'NKWCONSTReformIdent) 158 159(de NKWCONSTReformQuote (U) 160 (CompileConstant (cadr U))) 161 162(put 'QUOTE 'NKWCONSTReformPseudo 'NKWCONSTReformQuote) 163 164(de NKWCONSTReformLis (U) 165 (foreach x in U collect (NKWCONSTReform x))) 166 167(de NKWCONSTReformLoc (U) %. To handle &Foo[23] 168(PROGN (SETQ U (NKWCONSTReform (cadr U))) 169 (COND ((neq (car U) 'GetMem) 170 (ErrorPrintF "*** Illegal constant addressing expression %r" 171 (list 'Loc U))) (t 172 (cadr U))))) 173 174(put 'Loc 'NKWCONSTReformPseudo 'NKWCONSTReformLoc) 175 176(de NKWCONSTReformIDLoc (U) 177 (FindIDNumber (cadr U))) 178 179(put 'IDLoc 'NKWCONSTReformPseudo 'NKWCONSTReformIDLoc) 180 181(de LookupOrAddASMSymbol (U) 182(PROG (x) 183 (COND ((not (SETQ x (get U 'ASMSymbol))) (SETQ x (AddASMSymbol U)))) 184 (return x))) 185 186 187(de AddASMSymbol (U) 188(PROG (x) 189 (SETQ x (COND ((and (ASMSymbolP U) (not (get U 'EntryPoint))) U) (t 190 (StringGensym)))) 191 (put U 'ASMSymbol x) 192 (return x))) 193 194 195(de FindLabel (x) 196(PROG (Y) 197 (return (COND ((SETQ Y (Atsoc x LocalLabels*)) (cdr Y)) 198 ((SETQ Y (get x 'ASMSymbol)) Y) 199 ((SETQ Y (get x 'wconst)) Y) (t 200 (FindLocalLabel x)))))) 201 202 203(de FindLocalLabel (x) 204(PROG (Y) 205 (return (COND ((SETQ Y (Atsoc x LocalLabels*)) (cdr Y)) (t 206 207 (PROGN (SETQ LocalLabels* (cons (cons x (SETQ Y (StringGensym))) LocalLabels*)) 208 Y)))))) 209 210 211(de FindGlobalLabel (x) 212 (or (get x 'ASMSymbol) (ErrorPrintF "***** Undefined symbol %r" x))) 213 214% Kludge of the year, just to avoid having IDLOC defined during compilation 215% Removed so that IDLOC won't screw up the compiler by evaluating too soon: 216 217%(CompileTime (fluid '(macro))) 218 219%(SETQ macro 'macro) 220 221%(PutD 'IDLoc macro 222%(function (lambda (x) 223% (FindIDNumber (cadr x))))) 224 225 226