<mdl.comp>/cprint.mud.1

   1
   2 <DEFINE PRINT-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) RT)
   3         #DECL ((N) NODE (LN) FIX (K) <LIST [REST NODE]>)
   4         <COND (<SEGFLUSH .N .R>)
   5               (ELSE
   6                <ARGCHK .LN '(1 2) <NODE-NAME .N>>
   7                <SET RT <EANA <1 .K> ANY <NODE-NAME .N>>>
   8                <COND (<1? .LN>
   9                       <PUTREST .K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>
  10                       <PUT <2 .K>
  11                            ,KIDS
  12                            (<NODE1 ,QUOTE-CODE <2 .K> ATOM OUTCHAN ()>)>)>
  13                <EANA <2 .K> CHANNEL <NODE-NAME .N>>
  14                <PUT .N ,NODE-TYPE ,PRINT-CODE>
  15                <TYPE-OK? .RT .R>)>>
  16
  17 <DEFINE FLATSIZE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
  18         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
  19         <COND (<SEGFLUSH .N .R>)
  20               (ELSE
  21                <ARGCHK .LN '(2 3) FLATSIZE>
  22                <EANA <1 .K> ANY FLATSIZE>
  23                <EANA <2 .K> FIX FLATSIZE>
  24                <COND (<==? .LN 2>
  25                       <PUTREST <REST .K> (<NODE1 ,QUOTE-CODE .N FIX 10 ()>)>)>
  26                <EANA <3 .K> FIX FLATSIZE>
  27                <PUT .N ,NODE-TYPE ,ISUBR-CODE>
  28                <TYPE-OK? '<OR FIX FALSE> .R>)>>
  29
  30 <DEFINE UNPARSE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
  31         #DECL ((N) NODE (K) <LIST [REST NODE]>)
  32         <COND (<SEGFLUSH .N .R>)
  33               (ELSE
  34                <ARGCHK .LN '(1 2) UNPARSE>
  35                <EANA <1 .K> ANY UNPARSE>
  36                <COND (<1? .LN> <PUTREST .K (<NODE1 ,QUOTE-CODE .N FIX 10 ()>)>)>
  37                <EANA <2 .K> FIX UNPARSE>
  38                <PUT .N ,NODE-TYPE ,ISUBR-CODE>
  39                <TYPE-OK? STRING .R>)>>
  40
  41 <DEFINE TERPRI-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
  42         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
  43         <COND (<SEGFLUSH .N .R>)
  44               (ELSE
  45                <ARGCHK .LN '(0 1) TERPRI>
  46                <COND (<0? .LN>
  47                       <PUT .N
  48                            ,KIDS
  49                            <SET K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>>
  50                       <PUT <1 .K>
  51                            ,KIDS
  52                            (<NODE1 ,QUOTE-CODE <1 .K> ATOM OUTCHAN ()>)>)>
  53                <EANA <1 .K> CHANNEL TERPRI>
  54                <PUT .N ,NODE-TYPE ,ISUBR-CODE>
  55                <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,CRLF> ATOM) (ELSE FALSE)> .R>)>>
  56
  57 <DEFINE READCHR-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
  58         #DECL ((N) NODE (LN) FIX)
  59         <COND (<SEGFLUSH .N .R>)
  60               (ELSE
  61                <ARGCHK .LN '(0 1) <NODE-NAME .N>>
  62                <COND (<0? .LN>
  63                       <PUT .N
  64                            ,KIDS
  65                            <SET K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>>
  66                       <PUT <1 .K>
  67                            ,KIDS
  68                            (<NODE1 ,QUOTE-CODE <1 .K> ATOM INCHAN ()>)>)>
  69                <EANA <1 .K> CHANNEL <NODE-NAME .N>>
  70                <PUT .N ,NODE-TYPE ,ISUBR-CODE>
  71                <TYPE-OK? ANY .R>)>>
  72
  73 <PUT ,READCHR ANALYSIS ,READCHR-ANA>
  74
  75 <PUT ,NEXTCHR ANALYSIS ,READCHR-ANA>
  76
  77 <PUT ,PRINC ANALYSIS ,PRINT-ANA>
  78
  79 <PUT ,PRIN1 ANALYSIS ,PRINT-ANA>
  80
  81 <PUT ,PRINT ANALYSIS ,PRINT-ANA>
  82
  83 <PUT ,FLATSIZE ANALYSIS ,FLATSIZE-ANA>
  84
  85 <PUT ,UNPARSE ANALYSIS ,UNPARSE-ANA>
  86
  87 <PUT ,TERPRI ANALYSIS ,TERPRI-ANA>
  88
  89 <PUT ,CRLF ANALYSIS ,TERPRI-ANA>
  90
  91 <DEFINE PRINT-GEN (N W
  92                    "AUX" (K <KIDS .N>) (OB <1 .K>) (CH <2 .K>)
  93                          (RT <ISTYPE? <RESULT-TYPE .OB>>)
  94                          (PCOD <LENGTH <MEMQ <NODE-SUBR .N> ,PRINTERS>>) DAT
  95                          CDAT)
  96    #DECL ((N OB CH) NODE (K) <LIST [REST NODE]> (PCOD) FIX (DAT CDAT) DATUM)
  97    <SET DAT
  98         <GEN .OB
  99              <COND (<SIDE-EFFECTS .CH> <DATUM ,AC-C ,AC-D>)
 100                    (ELSE DONT-CARE)>>>
 101    <SET PCOD
 102         <+ <COND (<==? .RT ATOM> 3)
 103                  (<==? .RT STRING> 6)
 104                  (<==? .RT CHARACTER> 9)
 105                  (ELSE 0)>
 106            .PCOD>>
 107    <COND (<OR <==? <DATTYP .DAT> ,AC-A>
 108               <==? <DATVAL .DAT> ,AC-A>
 109               <==? <DATTYP .DAT> ,AC-B>
 110               <==? <DATVAL .DAT> ,AC-B>>
 111           <SET DAT
 112                <MOVE:ARG
 113                 .DAT
 114                 <DATUM <COND (<AND <TYPE? <DATTYP .DAT> ATOM>
 115                                    <ISTYPE? <DATTYP .DAT>>>
 116                               <DATTYP .DAT>)
 117                              (ELSE ,AC-C)>
 118                        ,AC-D>>>)>
 119    <SET CDAT <GEN .CH <DATUM ,AC-A ,AC-B>>>
 120    <SET DAT    <MOVE:ARG .DAT
 121                          <DATUM <COND (<OR <==? .RT ATOM> <==? .PCOD 12>> .RT)
 122                                       (ELSE ,AC-C)>
 123                                 ,AC-D>>>
 124    <RET-TMP-AC <MOVE:ARG .CDAT <DATUM ,AC-A ,AC-B>>>
 125    <RET-TMP-AC .DAT>
 126    <REGSTO T>
 127    <EMIT <INSTRUCTION `PUSHJ  `P*  <NTH ,IPRINTERS .PCOD>>>
 128    <MOVE:ARG <FUNCTION:VALUE T> .W>>
 129
 130 <SETG PRINTERS ![,PRINC ,PRIN1 ,PRINT!]>
 131
 132 <SETG IPRINTERS
 133       ![|CIPRIN
 134         |CIPRN1
 135         |CIPRNC
 136         |CPATM
 137         |CP1ATM
 138         |CPCATM
 139         |CPSTR
 140         |CP1STR
 141         |CPCSTR
 142         |CIPRIN
 143         |CIPRN1
 144         |CPCH!]>
 145 \f\ 3\ 3\ 3\ 3