<mdl.int>/gcgdgl.mud.1

   1
   2 <PACKAGE "GC-GRLOAD">
   3
   4 <ENTRY GC-GROUP-LOAD GC-GROUP-DUMP>
   5
   6 <USE "EDIT">
   7
   8 <COND (<G? ,MUDDLE 100> <SETG TNM1 "ETMP"> <SETG TNM2 "MUDT">)
   9       (ELSE <SETG TNM1 "_ETMP_"> <SETG TNM2 ">">)>
  10
  11 <SETG VCOMP
  12       <FORM COND
  13             (<FORM N==? ,MUDDLE <FORM GVAL MUDDLE>>
  14              <FORM ERROR RSUBR-CANT-RUN-IN-THIS-VERSION-OF-MUDDLE!-ERRORS>)>>
  15
  16 <DEFINE GC-GROUP-LOAD (STR
  17                        "OPTIONAL" NAM
  18                        "AUX" (CHN <OPEN "READB" .STR>) FSP (REDEFINE T))
  19         #DECL ((REDEFINE) <SPECIAL ANY>)
  20         <PROG ()
  21               <COND (<NOT <TYPE? .CHN CHANNEL>> <RETURN .CHN>)>
  22               <COND (<NOT <ASSIGNED? NAM>>
  23                      <SET NAM
  24                           <PARSE <MAPF ,STRING
  25                                        <FUNCTION (C) <MAPRET !"\\ .C>>
  26                                        <7 .CHN>>>>)>
  27                                       ;"To hack ugly file names. (TT, 75/10/07)"
  28               <PUT .NAM
  29                    CHANNEL
  30                    <SET FSP <LIST <7 .CHN> <8 .CHN> <9 .CHN> <10 .CHN>>>>
  31               <EVAL <GC-READ .CHN>>
  32               <CLOSE .CHN>
  33               .NAM>>
  34
  35 <DEFINE GC-GROUP-DUMP (STR
  36                        "OPTIONAL" NM (BKILLER T)
  37                        "AUX" (CHN <CHANNEL "PRINTB" .STR>)
  38                              (NAM
  39                               <COND (<ASSIGNED? NM> .NM)
  40                                     (ELSE <PARSE <7 .CHN>>)>)
  41                              (OC
  42                               <OPEN "PRINTB" ,TNM1 ,TNM2 <9 .CHN> <10 .CHN>>)
  43                              (FIXERS ()) FUNC BKS TEM TT HOLDANY GRP FIXES)
  44    #DECL ((CHN) CHANNEL (NAM) ATOM (OC) <OR CHANNEL FALSE> (FIXERS) LIST)
  45    <PROG ()
  46      <COND (<NOT .OC> <RETURN .OC>)>
  47      <COND (<OR <NOT <ASSIGNED? .NAM>> <NOT <TYPE? ..NAM LIST>>>
  48             <CLOSE .OC>
  49             <RETURN #FALSE ("Not a valid group name")>)>
  50      <SET GRP ..NAM>
  51      <SET FIXERS
  52           (<FORM PUT .NAM BLOCK <FORM UNGET <UNGET <GET .NAM BLOCK '.OBLIST>>>>
  53            !.FIXERS)>
  54      <MAPR <>
  55       <FUNCTION (OBP "AUX" (OB <1 .OBP>))
  56          <COND (<SET TEM <GET <FORM QUOTE .OBP> COMMENT>>
  57                 <SET FIXERS
  58                      (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM> !.FIXERS)>)>
  59          <COND (<SET TEM <GET .OBP BLOCK>>
  60                 <SET FIXERS
  61                      (<FORM PUT
  62                             <FORM QUOTE .OBP>
  63                             BLOCK
  64                             <FORM UNGET <UNGET .TEM>>>
  65                       !.FIXERS)>)>
  66          <COND
  67           (<AND <TYPE? .OB FORM> <NOT <EMPTY? .OB>>>
  68            <COND
  69             (<OR <==? <SET TEM <1 .OB>> DEFINE> <==? .TEM DEFMAC>>
  70              <COND
  71               (<AND
  72                 .BKILLER                                   ;"Breakpoint killer"
  73                 <G? <LENGTH .OB> 1>
  74                 <SET BKS
  75                      <GETPROP
  76                       <AND <GASSIGNED? <SET FUNC <GET <2 .OB> VALUE '<2
  77                                                                       .OB>>>>
  78                            <GLOC .FUNC>>
  79                       BREAKS>>>
  80                <PUTPROP <GLOC .FUNC> BREAKS>
  81                <REPEAT ()
  82                        <COND (<EMPTY? .BKS> <RETURN>)>
  83                        <COND (<TYPE? <SET HOLDANY <IN <1 .BKS>>> BREAK>
  84                               <SETLOC <1 .BKS> <2 .HOLDANY>>)>
  85                        <SET BKS <REST .BKS>>>)>
  86              <SET TEM <COMMENT-ON .OB>>
  87              <COND (<NOT <EMPTY? .TEM>>
  88                     <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .FIXERS>
  89                     <SET FIXERS .TEM>)>)
  90             (<AND <==? .TEM SETG>
  91                   <==? <LENGTH .OB> 3>
  92                   <TYPE? <SET NM <GET <2 .OB> VALUE '<2 .OB>>> ATOM>
  93                   <OR <TYPE? <SET TEM <3 .OB>> RSUBR>
  94                       <AND <GASSIGNED? .NM> <TYPE? <SET TEM ,.NM> RSUBR>>>
  95                   <==? .NM <2 .TEM>>>
  96              <COND (<AND <TYPE? <1 .TEM> CODE> <SET FIXES <GET .TEM RSUBR>>>
  97                     <SET FIXERS
  98                          (<FORM FIXIT <FORM QUOTE .TEM> .FIXES> !.FIXERS)>)
  99                    (<TYPE? <1 .TEM> CODE>
 100                     <PRINC
 101 "Warning:  RSUBR lacks fixups, only use in same MUDDLE version.  ">
 102                     <PRIN1 .NM>
 103                     <CRLF>
 104                     <SET FIXERS (,VCOMP !.FIXERS)>)>
 105              <COND (<NOT <EMPTY? <SET TT <ANON-SRCH .TEM>>>>
 106                     <PUTREST <REST .TT <- <LENGTH .TT> 1>> .FIXERS>
 107                     <SET FIXERS .TT>)>
 108              <COND (<TYPE? <SET TT <1 .TEM>> PCODE>
 109                     <SET FIXERS
 110                          (<FORM PUT
 111                                 <FORM QUOTE .TEM>
 112                                 1
 113                                 <PARSE <REST <UNPARSE .TT>>>>
 114                           !.FIXERS)>)>)>)>>
 115       .GRP>
 116      <GC-DUMP (<FORM MAPF
 117                      <>
 118                      <FORM GVAL EVAL>
 119                      <FORM SET .NAM <FORM QUOTE .GRP>>>
 120                .FIXERS)
 121               .OC>
 122      <RENAME .OC .STR>
 123      <CLOSE .OC>
 124      .NAM>>
 125
 126 <DEFINE COMMENT-ON (OB "AUX" (L ()) TEM TT)
 127    <COND
 128     (<NOT <MONAD? .OB>>
 129      <MAPR <>
 130            <FUNCTION (OBP)
 131                    <COND (<SET TEM <GET .OBP COMMENT>>
 132                           <SET L
 133                                (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM>
 134                                 !.L)>)>
 135                    <COND (<NOT <EMPTY? <SET TEM <COMMENT-ON <1 .OBP>>>>>
 136                           <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .L>
 137                           <SET L .TEM>)>>
 138            <REST .OB>>
 139      <COND (<SET TEM <GET <1 .OB> COMMENT>>
 140             <SET L (<FORM PUT <FORM QUOTE <1 .OB>> COMMENT .TEM> !.L)>)>
 141      <COND (<OR <SET TEM <GET <SET TT .OB> COMMENT>>
 142                 <SET TEM <GET <SET TT <REST .OB 0>> COMMENT>>>
 143             <SET L (<FORM PUT <FORM QUOTE .TT> COMMENT .TEM> !.L)>)>)
 144     (<SET TEM <GET .OB COMMENT>> <SET L (.TEM)>)>
 145    .L>
 146
 147 <DEFINE ANON-SRCH (R "AUX" (L ()) TEM)
 148    #DECL ((R) <PRIMTYPE VECTOR> (L) LIST)
 149    <MAPR <>
 150     <FUNCTION (THP "AUX" (THING <1 .THP>))
 151             <COND (<AND <TYPE? .THING RSUBR>
 152                         <G? <LENGTH .THING> 1>
 153                         <TYPE? <SET TEM <2 .THING>> ATOM>
 154                         <OR <NOT <GASSIGNED? .TEM>> <N==? ,.TEM .THING>>>
 155                    <COND (<AND <TYPE? <1 .THING> CODE>
 156                                <SET TEM <GET .THING RSUBR>>>
 157                           <SET L (<FORM FIXIT <FORM QUOTE .THING> .TEM> !.L)>)
 158                          (<TYPE? <1 .THING> CODE>
 159                           <PRINC
 160 "Warning:  RSUBR lacks fixups, only use in same MUDDLE version.  ">
 161                           <PRIN1 <2 .THING>>
 162                           <CRLF>)>)>
 163             <COND (<AND <TYPE? .THING RSUBR> <TYPE? <1 .THING> PCODE>>
 164                    <SET L
 165                         (<FORM PUT
 166                                <FORM QUOTE .THING>
 167                                1
 168                                <PARSE <REST <UNPARSE <1 .THING>>>>>
 169                          !.L)>)>
 170             <COND (<TYPE? .THING LOCD LOCR TYPE-W TYPE-C>
 171                    <SET L
 172                         (<FORM PUT
 173                                <FORM QUOTE .THP>
 174                                1
 175                                <PARSE <REST <UNPARSE .THING>>>>
 176                          !.L)>
 177                    <COND (<TYPE? .THING LOCD>
 178                           <PUT .THP 1 LOCD>)>)>>
 179     .R>
 180    .L>
 181
 182 <DEFINE UNGET (O)
 183         <MAPF ,LIST <FUNCTION (X) <GET .X OBLIST>> .O>>
 184 \f
 185 <ENDPACKAGE>
 186 \ 3\ 3