mim/development/mim/vaxc/fcode.mud

   1
   2 <GDECL (FCODE-CHANNEL)
   3        <OR FALSE CHANNEL>
   4        (FCODE-BUFFER)
   5        UVECTOR
   6        (FCODE-BUFFER-PAGE FCODE-FILE-POINTER MAX-BUFFERS)
   7        FIX
   8        (FCODE-BUFFER-CHANGED?)
   9        BOOLEAN
  10        (FCODE-LIST)
  11        <LIST [REST <OR FIX CODEVEC>]>
  12        (FCURRENT-CODE)
  13        CODEVEC
  14        (FCODE-COUNT FCURRENT-WORD FBYTE-OFFSET FSHIFT)
  15        FIX>
  16
  17 <SETG MAX-BUFFERS 5>
  18
  19 <MSETG FCODEVEC-LENGTH <* ,CODEVEC-LENGTH 4>>
  20
  21 <DEFINE INIT-FINAL-CODE ()
  22         <SETG FCURRENT-CODE <IUVECTOR ,CODEVEC-LENGTH 0>>
  23         <SETG FCODE-LIST (,FCURRENT-CODE)>
  24         <SETG FCODE-CHANNEL <>>
  25         <SETG FCODE-BUFFER <IUVECTOR ,CODEVEC-LENGTH 0>>
  26         <SETG FCODE-BUFFER-PAGE -1>
  27         <SETG FCODE-FILE-POINTER 0>
  28         <SETG FCODE-COUNT 1>
  29         <SETG FCURRENT-WORD 0>
  30         <SETG FBYTE-OFFSET 1>
  31         <SETG FSHIFT 32>>
  32
  33 <DEFINE RESET-FCODE ()
  34         <REPEAT ()
  35                 <COND (<TYPE? <1 ,FCODE-LIST> FIX>
  36                        <SETG FCODE-LIST <REST ,FCODE-LIST>>)
  37                       (<RETURN>)>>
  38         <SETG FCURRENT-CODE <1 ,FCODE-LIST>>
  39         <SETG FCODE-BUFFER-PAGE -1>
  40         <COND (,FCODE-CHANNEL <CLOSE ,FCODE-CHANNEL> <SETG FCODE-CHANNEL <>>)>
  41         <SETG FCODE-FILE-POINTER 0>
  42         <SETG FCODE-COUNT 1>
  43         <SETG FCURRENT-WORD 0>
  44         <SETG FBYTE-OFFSET 1>
  45         <SETG FSHIFT 32>>
  46
  47 <DEFINE OPEN-FCODE-FILE ("AUX" CH)
  48         <COND (<NOT <SET CH
  49                          <CHANNEL-OPEN DISK "CACHE.FILE" "CREATE" "BINARY">>>
  50                <ERROR <SYS-ERR "CACHE.FILE" .CH>>)>
  51         <SETG FCODE-CHANNEL .CH>
  52         T>
  53
  54 <DEFINE WRITE-FCODE (BUF PAGE "AUX" (CH ,FCODE-CHANNEL))
  55         #DECL ((BUF) UVECTOR (PAGE) FIX)
  56         <COND (<NOT ,FCODE-CHANNEL> <OPEN-FCODE-FILE>)>
  57         <SET CH ,FCODE-CHANNEL>
  58         <ACCESS .CH <* .PAGE ,CODEVEC-LENGTH>>
  59         <CHANNEL-OP .CH WRITE-BUFFER .BUF>
  60         T>
  61
  62 <DEFINE READ-FCODE (BUF PAGE "AUX" (CH ,FCODE-CHANNEL))
  63         <ACCESS .CH <* .PAGE ,CODEVEC-LENGTH>>
  64         <CHANNEL-OP .CH READ-BUFFER .BUF>>
  65
  66 <DEFINE ADD-BYTE-TO-FCODE (BYT
  67                            "AUX" RLST (CCODE ,FCURRENT-CODE)
  68                                  (CWORD ,FCURRENT-WORD) (OFF ,FBYTE-OFFSET)
  69                                  (SHFT ,FSHIFT) COUNT)
  70         #DECL ((SHFT BYT) FIX)
  71         <COND (<G? <SET SHFT <- .SHFT 8>> 0>
  72                <SETG FCURRENT-WORD <CHTYPE <ORB .CWORD <LSH .BYT .SHFT>> FIX>>)
  73               (ELSE
  74                <SET COUNT ,FCODE-COUNT>
  75                <COND (<EMPTY? .CCODE>
  76                       <SET RLST
  77                            <REST ,FCODE-LIST <- </ .COUNT ,CODEVEC-LENGTH> 1>>>
  78                       <COND (<1? <LENGTH .RLST>>
  79                              <SET CCODE <NEW-FCODE-BUFFER>>)
  80                             (ELSE <SET CCODE <2 .RLST>>)>)>
  81                <SET BYT <CHTYPE <ORB .CWORD .BYT> FIX>>
  82                <PUT .CCODE 1 .BYT>
  83                <SETG FCURRENT-CODE <REST .CCODE>>
  84                <SETG FCODE-COUNT <+ .COUNT 1>>
  85                <SETG FCURRENT-WORD 0>
  86                <SET SHFT 32>)>
  87         <SETG FSHIFT .SHFT>
  88         <SETG FBYTE-OFFSET <+ .OFF 1>>
  89         .OFF>
  90
  91 <DEFINE NEW-FCODE-BUFFER ("AUX" (RLST ,FCODE-LIST) CCODE
  92                                 (BPAGE ,FCODE-FILE-POINTER))
  93         <COND (<G? <LENGTH .RLST> ,MAX-BUFFERS>
  94                <MAPR <>
  95                      <FCN (BUFR "AUX" (BUF <1 .BUFR>))
  96                           <COND (<TYPE? .BUF UVECTOR>
  97                                  <PUT .BUFR 1 .BPAGE>
  98                                  <SET CCODE .BUF>
  99                                  <MAPLEAVE>)>>
 100                      .RLST>
 101                <WRITE-FCODE .CCODE .BPAGE>
 102                <SETG FCODE-FILE-POINTER <+ .BPAGE 1>>
 103                <PUTREST <REST .RLST <- <LENGTH .RLST> 1>> (.CCODE)>)
 104               (ELSE
 105                <SET CCODE <IUVECTOR ,CODEVEC-LENGTH 0>>
 106                <PUTREST <REST .RLST <- <LENGTH .RLST> 1>> (.CCODE)>)>
 107         .CCODE>
 108
 109 <DEFINE PUT-FCODE (DEST VAL
 110                    "AUX" (CL ,FCODE-LIST) (OFF ,FBYTE-OFFSET)
 111                          (CWORD ,FCURRENT-WORD) (SHFT ,FSHIFT))
 112    #DECL ((DEST VAL SHFT) FIX (CL) LIST)
 113    <COND (<AND <==? </ <+ .OFF 2> 4> </ <+ .DEST 3> 4>> <N==? .SHFT 32>>
 114           <SETG FCURRENT-WORD
 115                 <CHTYPE <PUTBITS .CWORD
 116                                  <BITS 8
 117                                        <NTH '![24 16 8 0!]
 118                                             <+ <MOD <+ .DEST 3> 4> 1>>>
 119                                  .VAL>
 120                         FIX>>)
 121          (ELSE
 122           <REPEAT ((PTR .DEST) WD CCODE)
 123                   #DECL ((CCODE) UVECTOR)
 124                   <COND (<L=? .PTR ,FCODEVEC-LENGTH>
 125                          <SET OFF </ <+ .PTR 3> 4>>
 126                          <SET SHFT
 127                               <NTH '![24 16 8 0!] <+ <MOD <+ .PTR 3> 4> 1>>>
 128                          <COND (<TYPE? <1 .CL> UVECTOR> <SET CCODE <1 .CL>>)
 129                                (<SET CCODE <GET-FCODE-BUFFER <1 .CL> WRITE>>)>
 130                          <SET WD
 131                               <PUTBITS <NTH .CCODE .OFF> <BITS 8 .SHFT> .VAL>>
 132                          <PUT .CCODE .OFF .WD>
 133                          <RETURN>)>
 134                   <COND (<EMPTY? <SET CL <REST .CL>>>
 135                          <ERROR OUT-OF-BOUNDS PUT-FCODE>)>
 136                   <SET PTR <- .PTR ,FCODEVEC-LENGTH>>>)>>
 137
 138 <DEFINE NTH-FCODE (DEST
 139                    "AUX" (CL ,FCODE-LIST) VAL (OFF ,FBYTE-OFFSET)
 140                          (CWORD ,FCURRENT-WORD) (SHFT ,FSHIFT))
 141    #DECL ((DEST) FIX (CL) LIST)
 142    <COND (<AND <==? </ <+ .OFF 2> 4> </ <+ .DEST 3> 4>> <N==? .SHFT 32>>
 143           <CHTYPE <GETBITS .CWORD
 144                            <BITS 8
 145                                  <NTH '![24 16 8 0!]
 146                                       <+ <MOD <+ .DEST 3> 4> 1>>>>
 147                   FIX>)
 148          (ELSE
 149           <REPEAT ((PTR .DEST) CCODE)
 150                   #DECL ((CCODE) UVECTOR)
 151                   <COND (<L=? .PTR ,FCODEVEC-LENGTH>
 152                          <SET OFF </ <+ .PTR 3> 4>>
 153                          <SET SHFT
 154                               <NTH '![24 16 8 0!] <+ <MOD <+ .PTR 3> 4> 1>>>
 155                          <COND (<TYPE? <1 .CL> UVECTOR> <SET CCODE <1 .CL>>)
 156                                (<SET CCODE <GET-FCODE-BUFFER <1 .CL> READ>>)>
 157                          <SET VAL
 158                               <CHTYPE <GETBITS <NTH .CCODE .OFF>
 159                                                <BITS 8 .SHFT>>
 160                                       FIX>>
 161                          <RETURN .VAL>)>
 162                   <COND (<EMPTY? <SET CL <REST .CL>>>
 163                          <ERROR OUT-OF-BOUNDS .DEST NTH-FCODE>)>
 164                   <SET PTR <- .PTR ,FCODEVEC-LENGTH>>>)>>
 165
 166 <DEFINE GET-FCODE-BUFFER (PAGE MODE)
 167         #DECL ((PAGE) FIX (MODE) ATOM)
 168         <COND (<==? .PAGE ,FCODE-BUFFER-PAGE>
 169                <AND <==? .MODE WRITE> <SETG FCODE-BUFFER-CHANGED? T>>)
 170               (ELSE
 171                <COND (<AND <G=? ,FCODE-BUFFER-PAGE 0> ,FCODE-BUFFER-CHANGED?>
 172                       <WRITE-FCODE ,FCODE-BUFFER ,FCODE-BUFFER-PAGE>)>
 173                <READ-FCODE ,FCODE-BUFFER .PAGE>
 174                <SETG FCODE-BUFFER-PAGE .PAGE>
 175                <COND (<==? .MODE READ> <SETG FCODE-BUFFER-CHANGED? <>>)
 176                      (ELSE <SETG FCODE-BUFFER-CHANGED? T>)>)>
 177         ,FCODE-BUFFER>
 178
 179 <DEFINE ADVANCE-FCODE (NUM)
 180         #DECL ((NUM) FIX)
 181         <REPEAT ()
 182                 <ADD-BYTE-TO-FCODE .NUM>
 183                 <COND (<0? <SET NUM <- .NUM 1>>> <RETURN>)>>>