mim/development/mim/mimc/nprint.mud

   1 <PACKAGE "NPRINT">
   2
   3 <ENTRY NODE-COMPLAIN NODE-PRINT>
   4
   5 <USE "COMPDEC" "NEWSTRUC">
   6
   7 <NEW-CHANNEL-TYPE INTCHAN DEFAULT
   8                   OPEN INTCHAN-OPEN
   9                   CLOSE INTCHAN-CLOSE
  10                   WRITE-BYTE INTCHAN-WRITE-BYTE
  11                   WRITE-BUFFER INTCHAN-WRITE-BUFFER>
  12
  13 <NEWSTRUC INTCHAN VECTOR
  14           INTOUT <OR CHANNEL FALSE>
  15           INTCOUNT FIX
  16           INTMAX FIX>
  17
  18 <DEFINE NODE-COMPLAIN (N "OPTIONAL" (MAX 80) "AUX" (P .N) TEM)
  19         #DECL ((N) NODE (MAX) FIX (P) <OR VECTOR NODE>)
  20         <REPEAT ((OPP .P))
  21                 <AND <EMPTY? .OPP> <RETURN>>
  22                 <OR <NODE-PRINT .OPP .N .MAX T> <RETURN>>
  23                 <OR <TYPE? <SET TEM <PARENT <SET P .OPP>>> NODE>
  24                     <RETURN>>
  25                 <OR <MEMQ .OPP <KIDS <SET OPP .TEM>>>
  26                     <RETURN>>>
  27         <NODE-PRINT .P .N .MAX>>
  28
  29 <DEFINE NODE-PRINT (N
  30                     "OPTIONAL" (LOSER <>) (MAX 80) (FLAT <>)
  31                     "AUX" (OUTC .OUTCHAN) NCHS
  32                           (OUTCHAN <CHANNEL-OPEN INTCHAN  ""
  33                                                  <COND (.FLAT <>)
  34                                                        (.OUTC)>
  35                                                  0 .MAX>))
  36         #DECL ((MAX) FIX (NCHS) ANY
  37                (OUTCHAN) <SPECIAL CHANNEL>
  38                (LOSER) <SPECIAL <OR FALSE NODE>>)
  39         <RESET .OUTCHAN>
  40         <M-HLEN .OUTCHAN <- <M-HLEN .OUTC> 2>>
  41         <COND (<PROG NACT ()
  42                      #DECL ((NACT) <SPECIAL FRAME>)
  43                      <NPRINT .N>
  44                      <>>
  45                <OR .FLAT <PRINC " ..." .OUTC>>
  46                <SET NCHS <>>)
  47               (ELSE <SET NCHS <INTCOUNT <CHANNEL-DATA .OUTCHAN>>>)>
  48         <OR .FLAT <CRLF .OUTC>>
  49         <CLOSE .OUTCHAN>
  50         .NCHS>
  51
  52 <DEFINE INTCHAN-OPEN (TYP OPER NM C-OR-F CNT MAX)
  53         <CHTYPE [.C-OR-F .CNT .MAX] INTCHAN>>
  54
  55 <DEFINE INTCHAN-CLOSE (CHANNEL OPER) T>
  56
  57 <DEFINE INTCHAN-WRITE-BYTE (CHAN OPER CHR
  58                             "AUX" (D <CHANNEL-DATA .CHAN>) (INO <INTOUT .D>))
  59         #DECL ((CHAN) CHANNEL)
  60         <COND (<NOT .INO>
  61                <COND (<G? <SET INO <+ <INTCOUNT .D> 1>> <INTMAX .D>>
  62                       <RETURN T .NACT>)
  63                      (ELSE
  64                       <INTCOUNT .D .INO>)>)
  65               (<N==? <INTCOUNT .D> <INTMAX .D>>
  66                <CHANNEL-OP <INTOUT .D> WRITE-BYTE .CHR>
  67                <INTCOUNT .D <+ <INTCOUNT .D> 1>>)>>
  68
  69 <DEFINE INTCHAN-WRITE-BUFFER (CHAN OPER STR "OPT" (N <LENGTH .STR>)
  70                               "AUX" (D <CHANNEL-DATA .CHAN>) (INO <INTOUT .D>))
  71         #DECL ((STR) STRING (CHAN) CHANNEL (N) FIX)
  72         <COND (<NOT .INO>
  73                <INTCOUNT .D <SET INO <MIN <INTMAX .D> <+ <INTCOUNT .D> .N>>>>
  74                <COND (<==? .INO <INTMAX .D>> <RETURN T .NACT>)>)
  75               (<L=? <SET N <+ .N <INTCOUNT .D>>> <INTMAX .D>>
  76                <CHANNEL-OP .INO WRITE-BUFFER .STR <- .N <INTCOUNT .D>>>
  77                <INTCOUNT .D .N>)
  78               (<N==? <INTCOUNT .D> <INTMAX .D>>
  79                <CHANNEL-OP .INO WRITE-BUFFER .STR <- <INTMAX .D> <INTCOUNT .D>>>
  80                <INTCOUNT .D <INTMAX .D>>)>>
  81
  82 <DEFINE NPRINT (N "AUX" (COD <NODE-TYPE .N>) TC (FLG <==? .N .LOSER>))
  83         #DECL ((N) NODE (COD TC) FIX)
  84         <AND .FLG <PRINC " **** ">>
  85         <COND (<OR <==? .COD ,FUNCTION-CODE> <==? .COD ,MFCN-CODE>>
  86                <PRINC "<FUNCTION ">
  87                <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> <>>
  88                <PRINC " ">
  89                <SEQ-PRINT <KIDS .N>>
  90                <PRINC ">">)
  91               (<==? .COD ,PROG-CODE>
  92                <PRINC "<">
  93                <PRIN1 <NODE-NAME .N>>
  94                <PRINC " ">
  95                <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> T>
  96                <PRINC " ">
  97                <SEQ-PRINT <KIDS .N>>
  98                <PRINC ">">)
  99               (<==? .COD ,MFIRST-CODE>
 100                <PRINC <NTH ,MAP-SPEC-PRINT <NODE-SUBR .N>>>)
 101               (<==? .COD ,MPSBR-CODE>
 102                <PRINC ",">
 103                <OR <AND <EMPTY? <KIDS .N>> some-subr>
 104                    <PRIN1 <NODE-NAME <1 <KIDS .N>>>>>)
 105               (<==? .COD ,COPY-CODE>
 106                <PRINC <NTH ,ST-CHRS
 107                            <SET TC
 108                                 <LENGTH
 109                                   <MEMQ <NODE-NAME .N>
 110                                         '[TUPLE UVECTOR VECTOR LIST]>>>>>
 111                <SEQ-PRINT <KIDS .N>>
 112                <PRINC <NTH ,EN-CHRS .TC>>)
 113               (<OR <==? .COD ,SEG-CODE> <==? .COD ,SEGMENT-CODE>>
 114                <PRINC "!">
 115                <COND (<NOT <EMPTY? <KIDS .N>>>
 116                       <NPRINT <1 <KIDS .N>>>)>)
 117               (<==? .COD ,BRANCH-CODE>
 118                <PRINC "(">
 119                <NPRINT <PREDIC .N>>
 120                <COND (<NOT <EMPTY? <CLAUSES .N>>>
 121                       <PRINC " ">
 122                       <SEQ-PRINT <CLAUSES .N>>)>
 123                <PRINC ")">)
 124               (<==? .COD ,QUOTE-CODE>
 125                <AND <TYPE? <NODE-NAME .N> VECTOR UVECTOR LIST FORM>
 126                     <PRINC !\'>>
 127                <PRIN1 <NODE-NAME .N>>)
 128               (<OR <==? .COD ,SET-CODE> <==? .COD ,FSET-CODE>>
 129                <PRINC "<">
 130                <PRIN1 SET>
 131                <PRINC " ">
 132                <SEQ-PRINT <KIDS .N>>
 133                <PRINC ">">)
 134               (<OR <MEMQ .COD ,LGV>
 135                    <AND <==? .COD ,SUBR-CODE>
 136                         <OR <AND <==? <NODE-SUBR .N> ,LVAL>
 137                                  <SET COD ,FLVAL-CODE>>
 138                             <AND <==? <NODE-SUBR .N> ,GVAL>
 139                                  <SET COD ,FGVAL-CODE>>>>>
 140                <COND (<OR <==? .COD ,LVAL-CODE> <==? .COD ,FLVAL-CODE>>
 141                       <PRINC !\.>)
 142                      (ELSE <PRINC !\,>)>
 143                <COND (<TYPE? <NODE-NAME .N> SYMTAB>
 144                       <PRIN1 <NAME-SYM <NODE-NAME .N>>>)
 145                      (ELSE <OR <AND <EMPTY? <KIDS .N>> some-atom>
 146                                <NPRINT <1 <KIDS .N>>>>)>)
 147               (<==? <NODE-NAME .N> INTH>
 148                <PRINC "<">
 149                <OR <EMPTY? <KIDS .N>> <NPRINT <2 <KIDS .N>>>>
 150                <PRINC " ">
 151                <OR <EMPTY? <KIDS .N>> <NPRINT <1 <KIDS .N>>>>
 152                <PRINC ">">)
 153               (ELSE
 154                <PRINC "<">
 155                <PRINC <NODE-NAME .N>>
 156                <PRINC " ">
 157                <SEQ-PRINT <KIDS .N>>
 158                <PRINC ">">)>
 159         <AND .FLG <PRINC " **** ">>>
 160
 161 <SETG MAP-SPEC-PRINT [",+" ",-" ",*" ",/" ",LIST"]>
 162
 163 <SETG LGV
 164       <UVECTOR ,LVAL-CODE ,FLVAL-CODE ,GVAL-CODE ,FGVAL-CODE
 165                ,ASSIGNED?-CODE>>
 166
 167 <SETG ST-CHRS ["(" "[" "![" "<TUPLE"]>
 168
 169 <SETG EN-CHRS [")" "]" "!]" ">"]>
 170
 171 <GDECL (MAP-SPEC-PRINT ST-CHRS EN-CHRS) <VECTOR [REST STRING]>
 172        (LGV) <UVECTOR [REST FIX]>>
 173
 174
 175 <DEFINE SEQ-PRINT (L) #DECL ((L) <LIST [REST NODE]>)
 176         <COND (<NOT <EMPTY? .L>>
 177                <NPRINT <1 .L>>
 178                <COND (<NOT <EMPTY? <SET L <REST .L>>>>
 179                       <MAPF <>
 180                             <FUNCTION (N)
 181                                 #DECL ((N) NODE)
 182                                 <PRINC " ">
 183                                 <NPRINT .N>>
 184                             .L>)>)>>
 185
 186 <DEFINE PRNARGL (B R "OPTIONAL" (INAUX <>) "AUX" (INOPT <>) (DC ()) (FIRST T))
 187         #DECL ((B) <LIST [REST SYMTAB]> (DC) LIST)
 188         <PRINC "(">
 189         <MAPF <>
 190               <FUNCTION (SYM "AUX" (COD <CODE-SYM .SYM>))
 191                       #DECL ((SYM) SYMTAB (COD) FIX)
 192                       <OR .FIRST <PRINC " ">>
 193                       <SET FIRST <>>
 194                       <COND (<==? .COD 1>
 195                              <PRINC "\"NAME\" ">
 196                              <PRIN1 <NAME-SYM .SYM>>)
 197                             (<L=? .COD 3>
 198                              <COND (<NOT .INAUX>
 199                                     <SET INAUX T>
 200                                     <PRINC "\"AUX\" ">)>
 201                              <COND (<==? .COD 2>
 202                                     <PRINC "(">
 203                                     <PRIN1 <NAME-SYM .SYM>>
 204                                     <PRINC " ">
 205                                     <NPRINT <INIT-SYM .SYM>>
 206                                     <PRINC ")">)
 207                                    (ELSE <PRIN1 <NAME-SYM .SYM>>)>)
 208                             (<==? .COD 4>
 209                              <PRINC "\"TUPLE\" ">
 210                              <PRIN1 <NAME-SYM .SYM>>)
 211                             (<==? .COD 5>
 212                              <PRINC "\"ARGS\" ">
 213                              <PRIN1 <NAME-SYM .SYM>>)
 214                             (<L=? .COD 9>
 215                              <COND (<NOT .INOPT>
 216                                     <SET INOPT T>
 217                                     <PRINC "\"OPTIONAL\" ">)>
 218                              <COND (<L=? .COD 7>
 219                                     <PRINC "(">
 220                                     <AND <==? .COD 6> <PRINC "'">>
 221                                     <PRIN1 <NAME-SYM .SYM>>
 222                                     <PRINC " ">
 223                                     <NPRINT <INIT-SYM .SYM>>
 224                                     <PRINC ")">)
 225                                    (ELSE
 226                                     <AND <==? .COD 8> <PRINC "'">>
 227                                     <PRIN1 <NAME-SYM .SYM>>)>)
 228                             (<==? .COD 10>
 229                              <PRINC "\"CALL\" ">
 230                              <PRIN1 <NAME-SYM .SYM>>)
 231                             (<==? .COD 11>
 232                              <PRINC "\"BIND\" ">
 233                              <PRIN1 <NAME-SYM .SYM>>)
 234                             (ELSE
 235                              <AND <==? .COD 12> <PRINC "'">>
 236                              <PRIN1 <NAME-SYM .SYM>>)>
 237                       <COND (<N==? <DECL-SYM .SYM> ANY>
 238                              <SET DC
 239                                   ((<NAME-SYM .SYM>)
 240                                    <DECL-SYM .SYM>
 241                                    !.DC)>)>>
 242               .B>
 243         <COND (<AND .R <N==? .R ANY>> <SET DC ('(VALUE) .R !.DC)>)>
 244         <PRINC ")">
 245         <COND (<NOT <EMPTY? .DC>> <PRINC " "> <PRIN1 <CHTYPE .DC DECL>>)>>
 246
 247
 248
 249
 250
 251 <ENDPACKAGE>