mim/development/mim/vaxc/channel-type.mud

   1 <PACKAGE "CHANNEL-TYPE">
   2
   3 <ENTRY CT-QUERY>
   4
   5 <USE "NEWSTRUC">
   6
   7 <NEWSTRUC SDTABLE VECTOR
   8           SD-NAME ATOM
   9           SD-INHERIT <OR FALSE ATOM <LIST [REST ATOM]>>
  10           SD-OPER <LIST [REST ATOM <OR MSUBR ATOM FALSE>]>>
  11
  12 <GDECL (CHANNEL-TYPES) <LIST [REST ATOM SDTABLE]>>
  13
  14 <DEFINE NEW-CHANNEL-TYPE (SNAME INHERIT
  15                          "TUPLE" OPS
  16                          "AUX" ST TL SD LOSER)
  17         #DECL ((SNAME) ATOM (INHERIT) <OR ATOM FALSE <LIST [REST ATOM]>>
  18                (OPS) <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]> (ST) LIST
  19                (TL) <OR LIST FALSE> (LOSER) ATOM)
  20         <COND (<NOT <GASSIGNED? CHANNEL-TYPES>>
  21                <SETG CHANNEL-TYPES <SET ST ()>>)
  22               (<SET ST ,CHANNEL-TYPES>)>
  23         <COND (<OR <NOT <SET TL <MEMQ .SNAME .ST>>>
  24                    <AND <ASSIGNED? REDEFINE> .REDEFINE>
  25                    <ERROR .SNAME
  26                           ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE!-ERRORS
  27                           NEW-CHANNEL-TYPE>>
  28                <SET SD <CHTYPE [.SNAME .INHERIT <LIST !.OPS>] SDTABLE>>
  29                <COND (.TL <2 .TL .SD>)
  30                      (<SETG CHANNEL-TYPES (.SNAME .SD !.ST)>)>
  31                .SNAME)>>
  32
  33 <DEFINE SET-TYPE-FCN (STYPE OPER FCN "AUX" SD OL)
  34         #DECL ((STYPE) ATOM (OPER) ATOM (FCN) <OR ATOM MSUBR FALSE>
  35                (OL) <OR LIST FALSE> (SD) <OR FALSE SDTABLE>)
  36         <COND (<SET SD <GET-CHANNEL-TYPE .STYPE>>
  37                <COND (<SET OL <MEMQ .OPER <SD-OPER .SD>>> <2 .OL .FCN>)
  38                      (<SD-OPER .SD (.OPER .FCN !<SD-OPER .SD>)>)>
  39                .OPER)>>
  40
  41 <DEFINE SET-TYPE-INHERIT (STYPE INHERIT "AUX" SD LOSER)
  42    #DECL ((STYPE) ATOM (INHERIT) <OR ATOM FALSE <LIST [REST ATOM]>>
  43           (SD) <OR SDTABLE FALSE> (LOSER) ATOM)
  44    <COND
  45     (<SET SD <GET-CHANNEL-TYPE .STYPE>>
  46      <SD-INHERIT .SD .INHERIT>)>>
  47
  48 <DEFINE GET-CHANNEL-TYPE (STYPE "AUX" TL)
  49   #DECL ((STYPE) ATOM (TL) <OR FALSE LIST>)
  50   <COND (<AND <GASSIGNED? CHANNEL-TYPES> <SET TL <MEMQ .STYPE ,CHANNEL-TYPES>>>
  51          <2 .TL>)
  52         (#FALSE ("NO SUCH CHANNEL TYPE"))>>
  53
  54 <DEFINE CT-QUERY (STYPE OPER "OPTIONAL" (DEPTH 0) "AUX" SL SD TL INH RES)
  55    #DECL ((STYPE OPER) ATOM (TL SL) <OR LIST FALSE> (DEPTH) FIX
  56           (SD) <OR SDTABLE FALSE>
  57           (INH) <OR FALSE ATOM LIST>)
  58    <COND
  59     (<SET SD <GET-CHANNEL-TYPE .STYPE>>
  60      <SET RES
  61       <COND
  62        (<SET TL <MEMQ .OPER <SD-OPER .SD>>> <2 .TL>)
  63        (<SET TL <MEMQ * <SD-OPER .SD>>> <2 .TL>)
  64        (<SET INH <SD-INHERIT .SD>>
  65         <COND (<G? <SET DEPTH <+ .DEPTH 1>> 5>
  66                <ERROR INHERITANCE-DEPTH-TOO-GREAT!-ERRORS
  67                       .STYPE .OPER CT-QUERY>)>
  68         <COND (<TYPE? .INH ATOM> <CT-QUERY .INH .OPER .DEPTH>)
  69               (T
  70                <MAPF <>
  71                      <FUNCTION (ATM "AUX" FOO)
  72                              #DECL ((ATM) ATOM)
  73                              <COND (<SET FOO
  74                                          <CT-QUERY .ATM .OPER .DEPTH>>
  75                                     <MAPLEAVE .FOO>)>>
  76                      .INH>)>)
  77       (T
  78        #FALSE ("CHANNEL TYPE DOESN'T DEFINE OPERATION"))>>
  79      <COND (<TYPE? .RES MSUBR> <2 .RES>)
  80            (T .RES)>)
  81     (#FALSE ("NO SUCH CHANNEL TYPE"))>>
  82
  83 <ENDPACKAGE>
  84