mim/development/mim/mimc/mimc-grdump.mud

   1
   2 <PACKAGE "MIMC-GRDUMP">
   3
   4 <ENTRY MIMC-GROUP-DUMP DUMP-CODE>
   5
   6 <USE "COMFIL" "COMPDEC" "HASH">
   7
   8 <MSETG M$$PRINT 5>
   9
  10 <MSETG M$$OFF-FIX 1>
  11
  12 <MSETG M$$OFF-DCL 2>
  13
  14 <MSETG M$$OFF-ELT 3>
  15
  16 <MSETG M$$NTYPE 1>
  17
  18 <MSETG M$$PTYPE 2>
  19
  20 <MSETG M$$TYOFF 6>
  21
  22 <MSETG M$$TYPE-INFO-SIZE 1024>
  23
  24 <MSETG TUP-CHAN 1>
  25
  26 <MSETG TUP-OBL 2>
  27
  28 <MSETG TUP-BUF 3>
  29
  30 <MSETG TUP-BUFL 4>
  31
  32 <MSETG BUFLNT 1024>
  33
  34 <MSETG BACK-SLASH <ASCII 92>>
  35
  36
  37 ; "PRINT's magic finite-state machine for atoms"
  38
  39 <SETG M$$FS-NSTATE 9>   ; "# states, not counting terminals"
  40 <SETG M$$FS-NOSLASH <+ ,M$$FS-NSTATE 1>>        ; "No initial \ needed"
  41 <SETG M$$FS-SLASH1 <+ ,M$$FS-NSTATE 2>> ; "Initial \ needed"
  42 <SETG M$$FS-SLASH2 <+ ,M$$FS-NSTATE 3>> ; "Initial \ needed, done otherwise"
  43 <SETG M$$END-STATE 6>   ; "Slot in state for end of string"
  44 <MANIFEST M$$FS-NSTATE M$$FS-NOSLASH M$$FS-SLASH1 M$$FS-SLASH2 M$$END-STATE>
  45
  46 <GDECL (BUFFER) STRING (I$FLOAT-TABLE!-INTERNAL) <VECTOR [REST FLOAT]>
  47        (M$$TYPE-INFO!-INTERNAL) <VECTOR [REST <OR TYPE-ENTRY FALSE>]>>
  48
  49 <SETG M$$R-BACKS 15>
  50 <SETG M$$R-MIN-NUM-PART 17>
  51 <SETG M$$R-MAX-ATM-BRK 13>
  52 <MANIFEST M$$R-MAX-ATM-BRK M$$R-BACKS M$$R-MIN-NUM-PART>
  53
  54 <SETG BUFFER <ISTRING ,BUFLNT>>
  55
  56 <SETG ROOT-OBL <ROOT>>
  57
  58 <DEFINE MIMC-GROUP-DUMP (STR NAM TEMPCH
  59                        "AUX" OUTCHAN BKS POS TEM
  60                              (OBL <COND (<EMPTY? .OBLIST> FULL-OBL) (BLOCK)>)
  61                              (OOBLIST .OBLIST) (GROUP-INDICATOR DEFINE)
  62                              (IOTUP <TUPLE 0 0 ,BUFFER 0>)
  63                              IOB MACRO-NAME FUNC TEMP GOODS THIS-FORM)
  64    #DECL ((STR) STRING (POS) <PRIMTYPE LIST> (OUTCHAN) <OR FALSE <CHANNEL 'DISK>>
  65           (NAM OBL GROUP-INDICATOR) ATOM (GOODS) LIST (THIS-FORM) FORM)
  66    <UNWIND
  67     <PROG ()
  68       <COND (<NOT <SET OUTCHAN <OPEN "PRINT" .STR>>>
  69              <RETURN .OUTCHAN>)>
  70       <SET IOB <GETPROP .NAM .OBL '.OOBLIST>>
  71       <PUT .IOTUP ,TUP-CHAN .OUTCHAN>
  72       <PUT .IOTUP ,TUP-OBL .IOB>
  73       <SET GOODS ..NAM>
  74       <REPEAT (TEM CH)
  75         <COND (<EMPTY? .GOODS> <RETURN>)>
  76         <SET MACRO-NAME <>>
  77         <COND
  78          (<AND <TYPE? <1 .GOODS> FORM>
  79                <SET THIS-FORM <1 .GOODS>>
  80                <G? <LENGTH .THIS-FORM> 1>
  81                <OR <==? DEFINE <1 .THIS-FORM>>
  82                    <AND <==? DEFMAC <1 .THIS-FORM>>
  83                         <SET MACRO-NAME <2 .THIS-FORM>>>>
  84                <TYPE? <SET FUNC <GETPROP <2 .THIS-FORM> VALUE '<2 .THIS-FORM>>>
  85                       ATOM>>
  86           <COND (<NOT <GASSIGNED? .FUNC>>)
  87                 (ELSE
  88                  <COND (<TYPE? <SET TEM ,.FUNC> FUNCTION>
  89                         <PUTREST <REST .THIS-FORM> .TEM>
  90                         <MIMC-PRINT .THIS-FORM .IOTUP>
  91                         <MIMC-CRLF .IOTUP>)
  92                        (<AND <TYPE? .TEM MACRO>
  93                              <NOT <EMPTY? .TEM>>
  94                              <TYPE? <1 .TEM> FUNCTION>>
  95                         <PUTREST <REST .THIS-FORM> <1 .TEM>>
  96                         <MIMC-PRINT .THIS-FORM .IOTUP>
  97                         <MIMC-CRLF .IOTUP>)
  98                        (<TYPE? .TEM INS-LIST ACCESS-LIST>
  99                         <COND (<TYPE? .TEM ACCESS-LIST>
 100                                <ACCESS <SET CH <1 .TEM>> <2 .TEM>>
 101                                <MIMC-PRINT <CHTYPE <4 .TEM> WORD> .IOTUP>
 102                                <MIMC-CRLF .IOTUP>
 103                                <CHANNEL-OP .OUTCHAN WRITE-BUFFER
 104                                            <TUP-BUF .IOTUP> <TUP-BUFL .IOTUP>>
 105                                <TUP-BUFL .IOTUP 0>
 106                                <REPEAT ((SIZ <- <3 .TEM> <2 .TEM>>)
 107                                         (BUF <TUP-BUF .IOTUP>))
 108                                   #DECL ((SIZ) FIX)
 109                                   <COND (<G? .SIZ ,BUFLNT>
 110                                          <CHANNEL-OP .CH READ-BUFFER .BUF>
 111                                          <CHANNEL-OP .OUTCHAN
 112                                                      WRITE-BUFFER .BUF>)
 113                                         (ELSE
 114                                          <CHANNEL-OP .CH READ-BUFFER .BUF .SIZ>
 115                                          <CHANNEL-OP .OUTCHAN
 116                                                      WRITE-BUFFER .BUF .SIZ>
 117                                          <COND (<G? <LENGTH .TEM> 4>
 118                                                 <SET TEM <5 .TEM>>
 119                                                 <SET SIZ <- <3 .TEM>
 120                                                             <2 .TEM> -1>>
 121                                                 <ACCESS <SET CH <1 .TEM>>
 122                                                         <2 .TEM>>
 123                                                 <AGAIN>)
 124                                                (ELSE <RETURN>)>)>
 125                                   <SET SIZ <- .SIZ ,BUFLNT>>>)
 126                               (ELSE
 127                                <MIMC-PRINT <CHTYPE <1 .TEM> WORD> .IOTUP>
 128                                <MIMC-CRLF .IOTUP>
 129                                <IDUMP-CODE <REST .TEM> .IOTUP>)>
 130                         <COND (.MACRO-NAME
 131                                <MIMC-OUTS "<COND (<AND <GASSIGNED? " .IOTUP>
 132                                <MIMC-PRIN-ATOM .FUNC .IOTUP>
 133                                <MIMC-OUTS "> <NOT <TYPE? ," .IOTUP>
 134                                <MIMC-PRIN-ATOM .FUNC .IOTUP>
 135                                <MIMC-OUTS " MACRO>>> <SETG " .IOTUP>
 136                                <MIMC-PRIN-ATOM .FUNC .IOTUP>
 137                                <MIMC-OUTS " <CHTYPE (," .IOTUP>
 138                                <MIMC-PRIN-ATOM .FUNC .IOTUP>
 139                                <MIMC-OUTS ") MACRO>>)>" .IOTUP>
 140                                <MIMC-CRLF .IOTUP>)>)
 141                        (ELSE
 142                         <SET THIS-FORM
 143                              <FORM SETG
 144                                    <2 .THIS-FORM>
 145                                    <FORM QUOTE ,.FUNC>>>
 146                         <MIMC-PRINT .THIS-FORM .IOTUP>
 147                         <MIMC-CRLF .IOTUP>)>)>)
 148          (T
 149           <COND (<MONAD? <1 .GOODS>>
 150                  <MIMC-PRINT <1 .GOODS> .IOTUP>
 151                  <MIMC-CRLF .IOTUP>)
 152                 (T
 153                  <MIMC-PRINT <1 .GOODS> .IOTUP>
 154                  <MIMC-CRLF .IOTUP>)>)>
 155         <PUT .IOTUP ,TUP-OBL <SET IOB <GETPROP .GOODS .OBL '.IOB>>>
 156         <SET GOODS <REST .GOODS>>>
 157       <COND (<N==? <TUP-BUFL .IOTUP> 0>
 158              <CHANNEL-OP .OUTCHAN WRITE-BUFFER <TUP-BUF .IOTUP>
 159                          <TUP-BUFL .IOTUP>>)>
 160       <CLOSE <TUP-CHAN .IOTUP>>
 161       .NAM>
 162     <PROG ()
 163           <AND <ASSIGNED? OUTCHAN>
 164                <TYPE? .OUTCHAN CHANNEL>
 165                <CLOSE .OUTCHAN>>>>>
 166
 167 <DEFINE MIMC-PRINT (OBJ IOTUP)
 168         <MIMC-CRLF .IOTUP>
 169         <MIMC-PRIN1 .OBJ .IOTUP>>
 170
 171 <DEFINE MIMC-PRIN1 (DATA IOTUP
 172                     "AUX" (TYP <CALL TYPE .DATA>)
 173                           FROB (TYOFF <LSH .TYP -6>)
 174                           (INFO <NTH ,M$$TYPE-INFO!-INTERNAL <+ .TYOFF 1>>)
 175                           (PTYPE <M$$PRINT .INFO>) (CHN <TUP-CHAN .IOTUP>) LST)
 176         #DECL ((DATA) ANY (BREAK TYP TYSAT TYOFF) FIX (CHAN) CHANNEL
 177                (INFO) TYPE-ENTRY (PTYPE) <OR ATOM APPLICABLE FALSE>
 178                (LST) <PRIMTYPE LIST> (CHN) <CHANNEL 'DISK>
 179                (IOTUP) <TUPLE <CHANNEL 'DISK> LIST STRING FIX>)
 180         <COND (<AND .PTYPE
 181                     <NOT <TYPE? .PTYPE ATOM>>
 182                     <NOT <AND <TYPE? .DATA ATOM> <SET PTYPE ATOM>>>
 183                     <NOT <AND <TYPE? .DATA FCN-ATOM> <SET PTYPE ATOM>>>>
 184                <CHANNEL-OP .CHN
 185                            WRITE-BUFFER
 186                            <TUP-BUF .IOTUP>
 187                            <TUP-BUFL .IOTUP>>
 188                <CHANNEL-OP .CHN BUFOUT>
 189                <PUT .IOTUP ,TUP-BUFL 0>
 190                <PROG ((OUTCHAN .CHN))
 191                      #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
 192                      <APPLY .PTYPE .DATA>
 193                      <CHANNEL-OP .CHN BUFOUT>>)
 194               (<==? .PTYPE ATOM>
 195                <COND (<AND <TYPE? .DATA FCN-ATOM>
 196                            <GASSIGNED? CTLZ-PRINT>
 197                            ,CTLZ-PRINT>
 198                       <MIMC-OUTC <ASCII 26> .IOTUP>)>
 199                <MIMC-PRIN-ATOM <CHTYPE .DATA ATOM> .IOTUP>)
 200               (<==? .PTYPE FIX> <I$PRIN-FIX .DATA .IOTUP>)
 201               (<==? .PTYPE FLOAT> <I$PRIN-FLOAT .DATA .IOTUP>)
 202               (<==? .PTYPE STRING>
 203                <MIMC-OUTC !\" .IOTUP>
 204                <MAPF <>
 205                      <FUNCTION (CHR)
 206                           <COND (<OR <==? .CHR !\"> <==? .CHR ,BACK-SLASH>>
 207                                  <MIMC-OUTC ,BACK-SLASH .IOTUP>)>
 208                           <MIMC-OUTC .CHR .IOTUP>>
 209                      <CHTYPE .DATA STRING>>
 210                <MIMC-OUTC !\" .IOTUP>)
 211               (<==? .PTYPE BYTES>
 212                <MIMC-OUTS "!{" .IOTUP>
 213                <MAPR <>
 214                      <FUNCTION (BP "AUX" (BY <1 .BP>))
 215                              #DECL ((BP) BYTES)
 216                              <I$PRIN-FIX .BY .IOTUP>
 217                              <COND (<NOT <EMPTY? <REST .BP>>>
 218                                     <MIMC-OUTC <ASCII 32> .IOTUP>)>>
 219                      <CHTYPE .DATA BYTES>>
 220                <MIMC-OUTS "!}" .IOTUP>)
 221               (<==? .PTYPE CHARACTER>
 222                <COND (<OR <G? <CHTYPE .DATA FIX> *177*>
 223                           <L? <CHTYPE .DATA FIX> 0>>
 224                       <MIMC-OUTS "#CHARACTER *" .IOTUP>
 225                       <MIMC-PRIN-OCT <CHTYPE .DATA FIX> .IOTUP>
 226                       <MIMC-OUTC !\* .IOTUP>)
 227                      (ELSE
 228                       <MIMC-OUTS "!\\" .IOTUP>
 229                       <MIMC-OUTC .DATA .IOTUP>)>)
 230               (<==? .PTYPE ADECL>
 231                <MIMC-PRIN1 <1 <CHTYPE .DATA VECTOR>> .IOTUP>
 232                <MIMC-OUTC !\: .IOTUP>
 233                <MIMC-PRIN1 <2 <CHTYPE .DATA VECTOR>> .IOTUP>)
 234               (<AND <OR <==? .PTYPE FORM> <==? .PTYPE SEGMENT>>
 235                     <==? <LENGTH <CHTYPE .DATA LIST>> 2>
 236                     <OR <AND <==? <SET FROB <1 <CHTYPE .DATA LIST>>> LVAL>
 237                              <SET FROB !\.>>
 238                         <AND <==? .FROB GVAL> <SET FROB !\,>>
 239                         <AND <==? .FROB QUOTE> <SET FROB !\'>>>>
 240                <COND (<==? .PTYPE SEGMENT> <MIMC-OUTC !\! .IOTUP>)>
 241                <MIMC-OUTC .FROB .IOTUP>
 242                <MIMC-PRIN1 <2 <CHTYPE .DATA LIST>> .IOTUP>)
 243               (<OR <AND <==? .PTYPE FORM> <MIMC-OUTC !\< .IOTUP>>
 244                    <AND <==? .PTYPE LIST> <MIMC-OUTC !\( .IOTUP>>
 245                    <AND <==? .PTYPE SEGMENT> <MIMC-OUTS "!<" .IOTUP>>>
 246                <MAPR <>
 247                      <FUNCTION (LP "AUX" (OBJ <1 .LP>))
 248                              #DECL ((LP) LIST)
 249                              <MIMC-PRIN1 .OBJ .IOTUP>
 250                              <COND (<NOT <EMPTY? <REST .LP>>>
 251                                     <MIMC-OUTC <ASCII 32> .IOTUP>)>>
 252                      <CHTYPE .DATA LIST>>
 253                <COND (<N==? .PTYPE LIST> <MIMC-OUTC !\> .IOTUP>)
 254                      (ELSE <MIMC-OUTC !\) .IOTUP>)>)
 255               (<==? .PTYPE OFFSET>
 256                <MIMC-OUTS "%<OFFSET " .IOTUP>
 257                <I$PRIN-FIX <M$$OFF-FIX <CHTYPE .DATA VECTOR>> .IOTUP>
 258                <COND (<TYPE? <SET FROB <M$$OFF-DCL <CHTYPE .DATA VECTOR>>>
 259                              ATOM>
 260                       <MIMC-OUTC <ASCII 32> .IOTUP>
 261                       <MIMC-PRIN-ATOM .FROB .IOTUP>)
 262                      (ELSE <MIMC-OUTS " '" .IOTUP> <MIMC-PRIN1 .FROB .IOTUP>)>
 263                <COND (<TYPE? <SET FROB <M$$OFF-ELT <CHTYPE .DATA VECTOR>>>
 264                              ATOM>
 265                       <MIMC-OUTC <ASCII 32> .IOTUP>
 266                       <MIMC-PRIN-ATOM .FROB .IOTUP>)
 267                      (.FROB <MIMC-OUTS " '" .IOTUP> <MIMC-PRIN1 .FROB .IOTUP>)>
 268                <MIMC-OUTC !\> .IOTUP>)
 269               (<==? .PTYPE TYPE-C> <I$PRIN-TYPE-W-C .DATA <> .IOTUP>)
 270               (<==? .PTYPE TYPE-W> <I$PRIN-TYPE-W-C .DATA T .IOTUP>)
 271               (<==? .PTYPE UVECTOR>
 272                <MIMC-OUTS "![" .IOTUP>
 273                <MAPR <>
 274                      <FUNCTION (NP "AUX" (N <1 .NP>))
 275                              #DECL ((NP) UVECTOR)
 276                              <I$PRIN-FIX .N .IOTUP>
 277                              <COND (<NOT <EMPTY? <REST .NP>>>
 278                                     <MIMC-OUTC <ASCII 32> .IOTUP>)>>
 279                      <CHTYPE .DATA UVECTOR>>
 280                <MIMC-OUTS "!]" .IOTUP>)
 281               (<==? .PTYPE VECTOR>
 282                <MIMC-OUTC !\[ .IOTUP>
 283                <MAPR <>
 284                      <FUNCTION (NP "AUX" (N <1 .NP>))
 285                              #DECL ((NP) VECTOR)
 286                              <MIMC-PRIN1 .N .IOTUP>
 287                              <COND (<NOT <EMPTY? <REST .NP>>>
 288                                     <MIMC-OUTC <ASCII 32> .IOTUP>)>>
 289                      <CHTYPE .DATA VECTOR>>
 290                <MIMC-OUTC !\] .IOTUP>)
 291               (<==? .DATA <>>
 292                <MIMC-OUTS "%<>" .IOTUP>)
 293               (<==? .PTYPE GVAL>
 294                <MIMC-OUTC !\, .IOTUP>
 295                <MIMC-PRIN-ATOM <CHTYPE .DATA ATOM> .IOTUP>)
 296               (<==? .PTYPE LVAL>
 297                <MIMC-OUTC !\. .IOTUP>
 298                <MIMC-PRIN-ATOM <CHTYPE .DATA ATOM> .IOTUP>)
 299               (<TYPE? .DATA WORD>
 300                <MIMC-OUTS "#WORD *" .IOTUP>
 301                <MIMC-PRIN-OCT <CHTYPE .DATA FIX> .IOTUP>
 302                <MIMC-OUTC !\* .IOTUP>)
 303               (<==? <M$$NTYPE .INFO> <M$$PTYPE .INFO>>
 304                <CHANNEL-OP .CHN
 305                            WRITE-BUFFER
 306                            <TUP-BUF .IOTUP>
 307                            <TUP-BUFL .IOTUP>>
 308                <CHANNEL-OP .CHN BUFOUT>
 309                <PUT .IOTUP ,TUP-BUFL 0>
 310                <PROG ((OUTCHAN .CHN))
 311                      #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
 312                      <PRIN1 .DATA>>)
 313               (ELSE
 314                <MIMC-OUTC !\# .IOTUP>
 315                <MIMC-PRIN-ATOM <M$$NTYPE .INFO> .IOTUP>
 316                <MIMC-OUTC <ASCII 32> .IOTUP>
 317                <MIMC-PRIN1 <CHTYPE .DATA <M$$PTYPE .INFO>> .IOTUP>)>>
 318
 319 <DEFINE I$PRIN-TYPE-W-C (DATA W-C IOTUP "AUX" ENTRY TYOFF)
 320         #DECL ((DATA) ANY (BREAK TYOFF) FIX (CHAN) CHANNEL (RTRN) FRAME
 321                (ENTRY) <OR TYPE-ENTRY FALSE>
 322                (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 323         <COND (.W-C <SET TYOFF <LSH <CALL TYPEWC .DATA> <- %,M$$TYOFF>>>)
 324               (ELSE <SET TYOFF <LSH .DATA %<- ,M$$TYOFF>>>)>
 325         <COND (<AND <G=? .TYOFF 0>
 326                     <L=? .TYOFF ,M$$TYPE-INFO-SIZE>
 327                     <SET ENTRY <NTH ,M$$TYPE-INFO!-INTERNAL <+ .TYOFF 1>>>>
 328                <COND (.W-C <MIMC-OUTS "%<TYPE-W " .IOTUP>)
 329                      (ELSE <MIMC-OUTS "%<TYPE-C " .IOTUP>)>
 330                <MIMC-PRIN-ATOM <M$$NTYPE .ENTRY> .IOTUP>
 331                <MIMC-OUTC <ASCII 32> .IOTUP>
 332                <MIMC-PRIN-ATOM <M$$PTYPE .ENTRY> .IOTUP>
 333                <MIMC-OUTC !\> .IOTUP>)
 334               (<ERROR BAD-TYPE-CODE!-ERRORS .TYOFF PRINT>)>>
 335
 336 <DEFINE MIMC-PRIN-OCT (NUM IOTUP)
 337         #DECL ((NUM) FIX (IOTUP)  <TUPLE CHANNEL LIST STRING FIX>)
 338         <COND (<0? .NUM> <MIMC-OUTC !\0 .IOTUP>)
 339               (ELSE
 340                <MIMC-POCT .NUM .IOTUP>)>>
 341
 342 <DEFINE MIMC-POCT (X IOTUP)
 343         #DECL ((X) FIX (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 344         <COND (<N==? .X 0>
 345                <MIMC-POCT <LSH .X -3> .IOTUP>
 346                <MIMC-OUTC <ASCII <+ <ANDB .X 7> <ASCII !\0>>> .IOTUP>)>>
 347
 348 <DEFINE I$PRIN-FIX (NUM IOTUP)
 349         #DECL ((NUM) FIX (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 350         <COND (<==? .NUM <CHTYPE <MIN> FIX>>
 351                <MIMC-OUTS "%<CHTYPE <MIN> FIX>" .IOTUP>)
 352               (<==? .NUM <CHTYPE <MAX> FIX>>
 353                <MIMC-OUTS "%<CHTYPE <MAX> FIX>" .IOTUP>)
 354               (<==? .NUM -0>
 355                <MIMC-OUTS "-0" .IOTUP>)
 356               (<L? .NUM 0>
 357                <MIMC-OUTC !\- .IOTUP>
 358                <I$PRIN-INT <- 0 .NUM> .IOTUP>)
 359               (<0? .NUM> <MIMC-OUTC !\0 .IOTUP>)
 360               (ELSE <I$PRIN-INT .NUM .IOTUP>)>>
 361
 362 <DEFINE I$PRIN-INT (NUM IOTUP)
 363         #DECL ((NUM) FIX (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 364         <COND (<NOT <0? .NUM>>
 365                <I$PRIN-INT </ .NUM 10> .IOTUP>
 366                <MIMC-OUTC <ASCII <+ %<ASCII !\0> <MOD .NUM 10>>> .IOTUP>)>>
 367
 368 <DEFINE I$PRIN-FLOAT (NUM IOTUP
 369                       "AUX" (MANT .NUM) (EXP 0) DIG (SIGD 7) (OFFSET 1))
 370         #DECL ((NUM MANT) FLOAT (EXP DIG SIGD) FIX
 371                (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 372         <COND (<==? .NUM ,MINFL> <MIMC-OUTS "%,MINFL" .IOTUP>)
 373               (<==? .NUM ,MAXFL> <MIMC-OUTS "%,MAXFL" .IOTUP>)
 374               (ELSE
 375                <COND (<L? .NUM 0.0>
 376                       <MIMC-OUTC !\- .IOTUP>
 377                       <SET MANT <SET NUM <- 0.0 .NUM>>>)>
 378                <COND (<G=? .NUM 10.0>
 379                       <REPEAT ()
 380                               <SET MANT </ .MANT 10.0>>
 381                               <SET EXP <+ .EXP 1>>
 382                               <COND (<L? .MANT 10.0>  <RETURN>)>>)
 383                      (<0? .NUM> <SET EXP -1>)
 384                      (<L? .NUM 1.0>
 385                       <REPEAT ()
 386                               <SET MANT <* .MANT 10.0>>
 387                               <SET EXP <- .EXP 1>>
 388                               <COND (<G=? .MANT 1.0> <RETURN>)>>)>
 389                <COND (<OR <G? .EXP 7> <L? .EXP -2>>
 390                       <I$PRIN-INT <SET DIG <FIX .MANT>> .IOTUP>
 391                       <I$PRIN-DEC <- .MANT .DIG> .SIGD .IOTUP .OFFSET>
 392                       <MIMC-OUTC !\E .IOTUP>
 393                       <COND (<G? .EXP .SIGD>
 394                              <MIMC-OUTC !\+ .IOTUP>
 395                              <I$PRIN-INT .EXP .IOTUP>)
 396                             (ELSE
 397                              <SET OFFSET 8>
 398                              <MIMC-OUTC !\- .IOTUP>
 399                              <I$PRIN-INT <- 0 .EXP> .IOTUP>)>)
 400                      (<G=? .EXP 0>
 401                       <COND (<L=? .EXP 7> <SET OFFSET <- 8 .EXP>>)>
 402                       ; "This may cause rounding to the next integer, so must do
 403                             addition BEFORE calling FIX"
 404                       <COND (<G? <FIX <+ <NTH ,I$FLOAT-TABLE!-INTERNAL .OFFSET>
 405                                          .NUM>>
 406                                  <FIX .NUM>>
 407                              <SET NUM <+ <NTH ,I$FLOAT-TABLE!-INTERNAL .OFFSET>
 408                                          .NUM>>
 409                              <SET OFFSET 1>)>
 410                       <I$PRIN-INT <SET DIG <FIX .NUM>> .IOTUP>
 411                       <I$PRIN-DEC <- .NUM .DIG> <- .SIGD .EXP> .IOTUP .OFFSET>)
 412                      (ELSE
 413                       <COND (<NOT <0? .NUM>>
 414                              <SET NUM <+ .NUM <8 ,I$FLOAT-TABLE!-INTERNAL>>>)>
 415                       <SET OFFSET 1>
 416                       <COND (<G=? .NUM 1.0>
 417                              <MIMC-OUTC !\1 .IOTUP>
 418                              <SET NUM <- .NUM 1.0>>)
 419                             (T
 420                              <MIMC-OUTC !\0 .IOTUP>)>
 421                       <I$PRIN-DEC .NUM .SIGD .IOTUP .OFFSET>)>)>>
 422
 423 <DEFINE I$PRIN-DEC (NUM MIN IOTUP OFFSET "AUX" (Z-COUNT 0))
 424         #DECL ((NUM) FLOAT (MIN OFF Z-COUNT) FIX (BUF) STRING
 425                (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 426         <MIMC-OUTC !\. .IOTUP>
 427         <COND (<0? .NUM>
 428                <MIMC-OUTC !\0 .IOTUP>)
 429               (ELSE <SET NUM <+ .NUM <NTH ,I$FLOAT-TABLE!-INTERNAL .OFFSET>>>
 430                <REPEAT (DIG) #DECL ((DIG) FIX)
 431                        <SET DIG <FIX <SET NUM <* .NUM 10.0>>>>
 432                        <COND (<0? .DIG>
 433                               <SET Z-COUNT <+ .Z-COUNT 1>>)
 434                              (ELSE <SET Z-COUNT 0>)>
 435                        <MIMC-OUTC <ASCII <+ %<ASCII !\0> .DIG>> .IOTUP>
 436                        <COND (<OR <0? <SET NUM <- .NUM .DIG>>>
 437                                   <L=? <SET MIN <- .MIN 1>> 0>>
 438                               <RETURN>)>>)>>
 439
 440
 441 <DEFINE MIMC-CRLF (IOTUP)
 442         <MAPF <> <FUNCTION (CH) <MIMC-OUTC .CH .IOTUP>> ,CRLF-STRING!-INTERNAL>>
 443
 444 <DEFINE MIMC-PRIN-ATOM (ATM IOTUP "AUX" (SP <SPNAME .ATM>) (O? <OBLIST? .ATM>)
 445                                         (OB <TUP-OBL .IOTUP>))
 446         #DECL ((CHAN) CHANNEL (ATM) ATOM (OB) <LIST [REST OBLIST]>
 447                (O?) <OR FALSE OBLIST>
 448                (IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 449         <PROG ()
 450               <MIMC-PRIN-ATM .SP .IOTUP>
 451               <COND (<AND .O?
 452                           <N==? .O? ,MIM-OBL>
 453                           <N==? .O? ,TMP-OBL>
 454                           <N==? .O? ,ROOT-OBL>
 455                           <NOT <MEMQ .O? .OB>>>
 456                      <MIMC-OUTS "!-" .IOTUP>
 457                      <SET SP <SPNAME <SET ATM <CHTYPE .O? ATOM>>>>
 458                      <SET O? <OBLIST? .ATM>>
 459                      <AGAIN>)
 460                     (<NOT .O?>
 461                      <ERROR CANT-PRINT-ATOM!-ERRORS .ATM>)>>>
 462
 463 <DEFINE MIMC-PRIN-ATM (STR IOTUP "AUX" (FSM ,I$ATM-FSM!-INTERNAL)
 464                      (CSTATE <1 .FSM>) CTRANS (TR-TABLE ,I$TRANS-TABLE!-INTERNAL)
 465                      TN)
 466         #DECL ((STR) STRING (TN) FIX (FSM) <VECTOR [REST BYTES]>
 467                (CSTATE) BYTES (CTRANS) FIX (TR-TABLE) BYTES)
 468         ; "Run FSM to decide if initial backslash needed.  If any character
 469            that can't be part of number is encountered, exit immediately,
 470            don't put  backslash in.  Other transitions out of states are
 471            E, ., 0-9, +/-, *, and end of string.  This is basically ripped
 472            off from old muddle."
 473         <COND (<NOT
 474                 <MAPF <>
 475                  <FUNCTION (CHR)
 476                    #DECL ((CHR) CHARACTER)
 477                    <COND (<L? <SET CTRANS <NTH .TR-TABLE <+ <ASCII .CHR> 1>>>
 478                               ,M$$R-MIN-NUM-PART>
 479                           ; "Not part of number, so done."
 480                           <MAPLEAVE>)
 481                          (<SET TN <+ <- .CTRANS ,M$$R-MIN-NUM-PART> 1>>)>
 482                    <COND (<L=? <SET TN <NTH .CSTATE .TN>> ,M$$FS-NSTATE>
 483                           ; "Legal state number, go to it"
 484                           <SET CSTATE <NTH .FSM .TN>>
 485                           <>)
 486                          (<N==? .TN ,M$$FS-NOSLASH>
 487                           ; "Leading ., so always need backslash"
 488                           <MAPLEAVE <>>)
 489                          (T
 490                           ; "Thing can't be number, so leave"
 491                           <MAPLEAVE>)>>
 492                  .STR>>
 493                <COND (<OR <G? .TN ,M$$FS-NSTATE>
 494                           <N==? <M$$END-STATE .CSTATE> ,M$$FS-NOSLASH>>
 495                       ; "Put in \ if hit terminal state before end of string
 496                          or if current-state's end-state calls for it."
 497                       <MIMC-OUTC <ASCII 92> .IOTUP>)>)>
 498         <MAPF <>
 499               <FUNCTION (CHAR) #DECL ((CHAR) CHARACTER)
 500                <SET CTRANS <NTH .TR-TABLE <+ <ASCII .CHAR> 1>>>
 501                <COND (<OR <L=? .CTRANS ,M$$R-MAX-ATM-BRK>
 502                           <==? .CTRANS ,M$$R-BACKS>>
 503                       <MIMC-OUTC <ASCII 92> .IOTUP>)>
 504                <MIMC-OUTC .CHAR .IOTUP>>
 505               .STR>>
 506
 507 <DEFINE MIMC-OUTC (CHR IOTUP "AUX" LNT)
 508         #DECL ((IOTUP) <TUPLE CHANNEL LIST STRING FIX>)
 509         <COND (<G? <SET LNT <+ <TUP-BUFL .IOTUP> 1>> ,BUFLNT>
 510                <CHANNEL-OP <TUP-CHAN .IOTUP>:<CHANNEL 'DISK>
 511                            WRITE-BUFFER <TUP-BUF .IOTUP>>
 512                <SET LNT 1>)>
 513         <PUT .IOTUP ,TUP-BUFL .LNT>
 514         <PUT <TUP-BUF .IOTUP> .LNT .CHR>>
 515
 516 <DEFINE MIMC-OUTS (STR IOTUP
 517                  "AUX" (LNT <TUP-BUFL .IOTUP>) (BUF <TUP-BUF .IOTUP>))
 518         #DECL ((IOTUP) <TUPLE CHANNEL LIST STRING FIX> (LNT) FIX
 519                (BUF) STRING)
 520         <REPEAT ()
 521                 <COND (<EMPTY? .STR> <PUT .IOTUP ,TUP-BUFL .LNT> <RETURN>)>
 522                 <COND (<G? <SET LNT <+ .LNT 1>> ,BUFLNT>
 523                        <CHANNEL-OP <TUP-CHAN .IOTUP>:<CHANNEL 'DISK>
 524                                    WRITE-BUFFER .BUF>
 525                        <SET LNT 1>)>
 526                 <PUT .BUF .LNT <1 .STR>>
 527                 <SET STR <REST .STR>>>>
 528
 529
 530 <DEFINE IDUMP-CODE (L IOTUP) #DECL ((L) LIST (IOTUP) TUPLE)
 531         <MAPF <>
 532               <FUNCTION (X)
 533                    #DECL ((X) <OR ATOM FORM>)
 534                    <COND
 535                     (<TYPE? .X ATOM>
 536                      <MIMC-PRIN-ATOM .X .IOTUP>
 537                      <MIMC-CRLF .IOTUP>)
 538                     (ELSE
 539                      <MIMC-OUTS "                   " .IOTUP>
 540                      <MIMC-OUTC !\< .IOTUP>
 541                      <MAPR <>
 542                            <FUNCTION (YP "AUX" (Y <1 .YP>) O)
 543                                 #DECL ((YP) <LIST ANY>)
 544                                 <COND (<TYPE? .Y ATOM>
 545                                        <MIMC-PRIN-ATOM .Y .IOTUP>)
 546                                       (ELSE
 547                                        <MIMC-PRIN1 .Y .IOTUP>)>
 548                                 <COND (<NOT <EMPTY? <REST .YP>>>
 549                                        <MIMC-OUTC <ASCII 32>
 550                                                   .IOTUP>)>>
 551                            .X>
 552                      <MIMC-OUTC !\> .IOTUP>
 553                      <MIMC-CRLF .IOTUP>)>>
 554               .L>>
 555
 556 <DEFINE DUMP-CODE (L CH OBL "AUX" (IOTUP <TUPLE .CH .OBL ,BUFFER 0>))
 557         <IDUMP-CODE .L .IOTUP>
 558         <CHANNEL-OP <TUP-CHAN .IOTUP>:<CHANNEL 'DISK>
 559                     WRITE-BUFFER <TUP-BUF .IOTUP> <TUP-BUFL .IOTUP>>
 560         T>
 561
 562 <ENDPACKAGE>