mim/development/mim/vax/mimlib/trace.mud

   1 <PACKAGE "TRACE">
   2
   3 <ENTRY TRACE UNTRACE TRACE-LIST TRACE-PRINTER
   4        IN-PRINT OUT-PRINT IN-BREAK OUT-BREAK
   5        TFUNCT TARGS TVALUE>
   6
   7 <USE "NEWSTRUC" "TTY">
   8
   9 <NEWSTRUC TAPPLICABLE LIST
  10           TAPP <OR MSUBR FUNCTION>
  11           TATOM ATOM
  12           IN-PRINT ANY
  13           OUT-PRINT ANY
  14           IN-BREAK ANY
  15           OUT-BREAK ANY
  16           TPRINTER ATOM>
  17
  18 <SETG TRACE-PRINTER PRIN1>
  19 <GDECL (TRACE-PRINTER) ATOM>
  20
  21 <DEFINE TRACE ("ARGS" ARGL)
  22         #DECL ((ARGL) LIST (A) ATOM (VAL) ANY (APP) TAPPLICABLE)
  23         <COND (<EMPTY? .ARGL> <>)
  24               (<TYPE? <1 .ARGL> ATOM>
  25                <TRACE-SPEC .ARGL>)
  26               (ELSE
  27                <MAPF <> ,TRACE-SPEC .ARGL>)>>
  28
  29 <DEFINE TRACE-SPEC (ARGL "AUX" A VAL APP (IP <>) (IB <>) (TEST T))
  30         #DECL ((ARGL) LIST (A) ATOM (VAL) ANY (APP) TAPPLICABLE)
  31         <REPEAT ()
  32                 <SET TEST T>
  33                 <COND (<EMPTY? .ARGL>
  34                        <COND (<OR .IP .IB <OUT-PRINT .APP> <OUT-BREAK .APP>>)
  35                              (ELSE
  36                               <IN-PRINT .APP T>
  37                               <OUT-PRINT .APP T>)>
  38                        <RETURN <COND (<ASSIGNED? APP> .APP)>>)
  39                       (<TYPE? <1 .ARGL> ATOM>
  40                        <SET A <1 .ARGL>>
  41                        <COND (<AND <NOT <EMPTY? <REST .ARGL>>>
  42                                    <TYPE? <2 .ARGL> FORM LVAL GVAL>>
  43                               <SET TEST <2 .ARGL>>)>
  44                        <COND (<=? <SPNAME .A> "BOTH">
  45                               <COND (<ASSIGNED? APP> <OUT-PRINT .APP .TEST>)
  46                                     (ELSE <SET IP .TEST>)>
  47                               <COND (<ASSIGNED? APP> <OUT-BREAK .APP .TEST>)
  48                                     (ELSE <SET IB .TEST>)>)
  49                              (<=? <SPNAME .A> "PRINT">
  50                               <COND (<ASSIGNED? APP> <OUT-PRINT .APP .TEST>)
  51                                     (ELSE <SET IP .TEST>)>)
  52                              (<=? <SPNAME .A> "BREAK">
  53                               <COND (<ASSIGNED? APP> <OUT-BREAK .APP .TEST>)
  54                                     (ELSE <SET IB .TEST>)>)
  55                              (ELSE
  56                               <COND (<GASSIGNED? .A>
  57                                      <COND (<TYPE? <SET VAL ,.A> TAPPLICABLE>
  58                                             <SET APP .VAL>
  59                                             <IN-PRINT .APP .IP>
  60                                             <IN-BREAK .APP .IB>
  61                                             <OUT-PRINT .APP <>>
  62                                             <OUT-BREAK .APP <>>
  63                                             <TPRINTER .APP ,TRACE-PRINTER>
  64                                             <SETG .A .APP>)
  65                                            (<TYPE? .VAL MSUBR FUNCTION>
  66                                             <UNTRACE .A>
  67                                             <SETG .A
  68                                                   <SET APP
  69                                                        <CHTYPE
  70                                                         <LIST .VAL
  71                                                               .A
  72                                                               .IP
  73                                                               <>
  74                                                               .IB
  75                                                               <>
  76                                                               ,TRACE-PRINTER>
  77                                                         TAPPLICABLE>>>
  78                                             <SETG TRACE-LIST
  79                                                   (.APP !,TRACE-LIST)>)
  80                                            (ELSE
  81                                             <ERROR CANT-TRACE!-ERRORS .A .VAL>
  82                                             <RETURN <>>)>)
  83                                     (ELSE
  84                                      <ERROR NO-VALUE!-ERRORS .A>
  85                                      <RETURN <>>)>)>)
  86                       (ELSE
  87                        <ERROR BAD-TRACE-SPECIFICATION!-ERRORS <1 .ARGL>>
  88                        <RETURN <>>)>
  89                 <COND (<AND <NOT <EMPTY? <SET ARGL <REST .ARGL>>>>
  90                             <NOT <TYPE? <1 .ARGL> ATOM>>
  91                             <==? .TEST <1 .ARGL>>>
  92                        <SET ARGL <REST .ARGL>>)>>>
  93
  94 <DEFINE UNTRACE ("TUPLE" AA "AUX" A)
  95         #DECL ((A) ATOM)
  96         <COND (<EMPTY? .AA>
  97                <MAPF <>
  98                      <FUNCTION (TA)
  99                                #DECL ((TA) TAPPLICABLE)
 100                                <SETG <TATOM .TA> <TAPP .TA>>
 101                                <DETRACE .TA>>
 102                      ,TRACE-LIST>
 103                <SETG TRACE-LIST ()>)
 104               (ELSE
 105                <REPEAT ()
 106                        <COND (<EMPTY? .AA> <RETURN>)>
 107                        <COND (<GASSIGNED? <SET A <1 .AA>>>
 108                               <REPEAT ((TL ,TRACE-LIST))
 109                                       #DECL ((TL) <LIST [REST TAPPLICABLE]>)
 110                                       <COND (<EMPTY? .TL>
 111                                              <COND (<TYPE? ,.A TAPPLICABLE>
 112                                                     <DETRACE ,.A>
 113                                                     <SETG .A <TAPP ,.A>>)>
 114                                              <RETURN>)
 115                                             (<==? .A <TATOM <1 .TL>>>
 116                                              <COND (<TYPE? ,.A TAPPLICABLE>
 117                                                     <SETG .A <TAPP <1 .TL>>>)>
 118                                              <DETRACE <1 .TL>>
 119                                              <SETG TRACE-LIST <REST .TL>>
 120                                              <RETURN>)
 121                                             (<LENGTH? .TL 1> ;"not in list"
 122                                              <COND (<TYPE? ,.A TAPPLICABLE>
 123                                                     <SETG .A <TAPP ,.A>>
 124                                                     <DETRACE ,.A>)>
 125                                              <RETURN>)
 126                                             (<==? .A <TATOM <2 .TL>>>
 127                                              <COND (<TYPE? ,.A TAPPLICABLE>
 128                                                     <SETG .A <TAPP <2 .TL>>>)>
 129                                              <DETRACE <2 .TL>>
 130                                              <PUTREST .TL <REST .TL 2>>
 131                                              <RETURN>)
 132                                             (ELSE <SET TL <REST .TL>>)>>)>
 133                        <SET AA <REST .AA>>>)>>
 134
 135 <DEFINE DETRACE (TAPP)
 136         #DECL ((TAPP) TAPPLICABLE)
 137         <IN-PRINT .TAPP <>>
 138         <OUT-PRINT .TAPP <>>
 139         <IN-BREAK .TAPP <>>
 140         <OUT-BREAK .TAPP <>>>
 141
 142 <SETG TRACE-LEVEL 0>
 143 <GDECL (TRACE-LEVEL) FIX>
 144
 145 <DEFINE TRACER (APP "TUPLE" ARGS
 146                 "AUX" (TFUNCT <TAPP .APP>) (TARGS .ARGS) TVALUE
 147                 (TR ,TRACE-LEVEL))
 148         #DECL ((APP) TAPPLICABLE (VAL) ANY
 149                (TARGS) <SPECIAL TUPLE> (TFUNCT TVALUE) <SPECIAL ANY> (TR) FIX)
 150         <UNWIND <PROG ()
 151                       <COND (<EVAL <IN-PRINT .APP>>
 152                              <PROG LERR!-INTERRUPTS
 153                                    ((RUN 0) (OUTCHAN ,DEBUG-CHANNEL))
 154                                    #DECL ((OUTCHAN) <SPECIAL CHANNEL>
 155                                           (LERR!-INTERRUPTS) <SPECIAL FRAME>)
 156                                    <COND (<==? .RUN 0>
 157                                           <SET RUN 1>
 158                                           <CHANNEL-OP .OUTCHAN FRESH-LINE>
 159                                           <AND <G? .TR 0> <INDENT-TO .TR>>
 160                                           <PRINC "IN:  ">
 161                                           <PRIN1 <TATOM .APP>>
 162                                           <MAPF <>
 163                                                 <FUNCTION (A)
 164                                                      <PRINC !\ >
 165                                                      <APPLY ,<TPRINTER .APP> .A>>
 166                                                 .TARGS>)>>)>
 167                       <COND (<EVAL <IN-BREAK .APP>>
 168                              <PROG LERR!-INTERRUPTS ((OUTCHAN ,DEBUG-CHANNEL)
 169                                                      (RUN 0))
 170                                    #DECL ((OUTCHAN) <SPECIAL CHANNEL>
 171                                           (LERR!-INTERRUPTS) <SPECIAL FRAME>)
 172                                    <COND (<==? .RUN 0>
 173                                           <SET RUN 1>
 174                                           <LISTEN IN-BREAK <TATOM .APP> .TARGS>)
 175                                          (ELSE
 176                                           <LISTEN IN-BREAK <TATOM .APP>>)>>)>
 177                       <SETG TRACE-LEVEL <+ .TR 1>>
 178                       <SET TVALUE <APPLY .TFUNCT !.TARGS>>
 179                       <SETG TRACE-LEVEL .TR>
 180                       <COND (<EVAL <OUT-PRINT .APP>>
 181                              <PROG LERR!-INTERRUPTS
 182                                    ((RUN 0) (OUTCHAN ,DEBUG-CHANNEL))
 183                                    #DECL ((OUTCHAN) <SPECIAL CHANNEL>
 184                                           (LERR!-INTERRUPTS) <SPECIAL FRAME>)
 185                                    <COND (<==? .RUN 0>
 186                                           <SET RUN 1>
 187                                           <CHANNEL-OP .OUTCHAN FRESH-LINE>
 188                                           <AND <G? .TR 0> <INDENT-TO .TR>>
 189                                           <PRINC "OUT: ">
 190                                           <PRIN1 <TATOM .APP>>
 191                                           <PRINC " => ">
 192                                           <APPLY ,<TPRINTER .APP> .TVALUE>
 193                                           <PRINC !\ >)>>)>
 194                       <COND (<EVAL <OUT-BREAK .APP>>
 195                              <PROG LERR!-INTERRUPTS ((OUTCHAN ,DEBUG-CHANNEL)
 196                                                      (RUN 0))
 197                                    #DECL ((OUTCHAN) <SPECIAL CHANNEL>
 198                                           (LERR!-INTERRUPTS) <SPECIAL FRAME>)
 199                                    <COND (<==? .RUN 0>
 200                                           <SET RUN 1>
 201                                           <LISTEN OUT-BREAK <TATOM .APP> .TVALUE>)
 202                                          (ELSE
 203                                           <LISTEN OUT-BREAK <TATOM .APP>>)>>)>
 204                       .TVALUE>
 205                 <SETG TRACE-LEVEL .TR>>>
 206
 207 <COND (<NOT <FEATURE? "COMPILER">> <APPLYTYPE TAPPLICABLE ,TRACER>)>
 208
 209 <SETG TRACE-LIST ()>
 210 <GDECL (TRACE-LIST) <LIST [REST TAPPLICABLE]>>
 211
 212 <DEFINE TAPPLICABLE-PRINT (TAPP "OPTIONAL" (OUTCHAN .OUTCHAN))
 213         #DECL ((TAPP) TAPPLICABLE (OUTCHAN) CHANNEL)
 214         <PRINC "%<TRACE">
 215         <COND (<AND <TYPE? <IN-PRINT .TAPP> ATOM>
 216                     <TYPE? <OUT-PRINT .TAPP> ATOM>
 217                     <NOT <IN-BREAK .TAPP>>
 218                     <NOT <OUT-BREAK .TAPP>>>
 219                <PRINC !\ >
 220                <PRIN1 <TATOM .TAPP>>)
 221               (ELSE
 222                <COND (<IN-PRINT .TAPP>
 223                       <PRINC " PRINT">
 224                       <COND (<NOT <TYPE? <IN-PRINT .TAPP> ATOM>>
 225                              <PRINC !\ >
 226                              <PRIN1 <IN-PRINT .TAPP>>)>)>
 227                <COND (<IN-BREAK .TAPP>
 228                       <PRINC " BREAK">
 229                       <COND (<NOT <TYPE? <IN-BREAK .TAPP> ATOM>>
 230                              <PRINC !\ >
 231                              <PRIN1 <IN-BREAK .TAPP>>)>)>
 232                <PRINC !\ >
 233                <PRIN1 <TATOM .TAPP>>
 234                <COND (<OUT-PRINT .TAPP>
 235                       <PRINC " PRINT">
 236                       <COND (<NOT <TYPE? <OUT-PRINT .TAPP> ATOM>>
 237                              <PRINC !\ >
 238                              <PRIN1 <OUT-PRINT .TAPP>>)>)>
 239                <COND (<OUT-BREAK .TAPP>
 240                       <PRINC " BREAK">
 241                       <COND (<NOT <TYPE? <OUT-BREAK .TAPP> ATOM>>
 242                              <PRINC !\ >
 243                              <PRIN1 <OUT-BREAK .TAPP>>)>)>)>
 244         <PRINC !\>>>
 245
 246 <COND (<NOT <FEATURE? "COMPILER">> <PRINTTYPE TAPPLICABLE ,TAPPLICABLE-PRINT>)>
 247
 248 <ENDPACKAGE>