MUDDLE/meddle.3

   1 <FLOAD "MICROM" ">" "DSK" >
   2 <PRINC "/XMED">
   3
   4 XMED!-
   5 MMED!-
   6 MEDDLE!-
   7
   8 <BLOCK (<MOBLIST MM!- 13> <ROOT>)>
   9 O UT ? HERE OB EB OB?
  10 P PA PT PC
  11 S -S I C R L K U D UR DL WR WL B F
  12 C: I: K:
  13 SC V & Q \v
  14 BK KB
  15 <ENDBLOCK>
  16
  17 <BLOCK (<MOBLIST IMM!-MM 23> <GET MM OBLIST> <ROOT>)>
  18
  19 <NEWTYPE OBANDCURS LIST>
  20
  21 <SETG INITOB ("NOTHING OPEN")>
  22
  23 <DEFINE MMED MMEDACT    ("AUX"  (CI!-M 1) (CO!-M ,INITOB)
  24                                 (CL+1!-M 2) (LST!-M ())
  25                                 (LOC!-M <GLOC INITOB>)
  26                                 (CLLN <- <13 .OUTCHAN> 4>)
  27                                 (OBPDL ())
  28                                 (VERBSW #FALSE ()))
  29         <PRINC "
  30 MEDDLE 2 Running.">
  31         <RDBRAK (<GET MM!- OBLIST><GET M!- OBLIST>)>>
  32
  33 <SETG MEDDLE <SETG XMED ,MMED>>
  34
  35 <DEFINE O (IT "AUX" (HOW <GET <TYPE .IT> O>))
  36         <COND (.HOW
  37                 <COND (<SET HOW <EVAL .HOW>>
  38                         <OR <==? <TYPE .IT> OBANDCURS> <==? <TYPE .IT> CURSOR> <D>>)
  39                       (ELSE .HOW)>)
  40               (ELSE #FALSE ("BAD TYPE"))>>
  41
  42 <PUT LOCD O '<O!-M .IT>>
  43
  44 <PUT CURSOR O '<NC!-M .IT>>
  45
  46 <PUT OBANDCURS O '<PROG ((LOBS ()) (NOBPDL <1 .IT>))
  47                         <UNOB>
  48                         <SET OBPDL <REST .NOBPDL>>
  49                         <NC!-M <2 .IT>>
  50                         <REPEAT () <AND <EMPTY? <REST .NOBPDL>> <RETURN T>>
  51                                 <SET LOBS (<1 .NOBPDL> !.LOBS)>
  52                                 <SET NOBPDL <REST .NOBPDL 4>>>
  53                         <REPEAT () <AND <EMPTY? .LOBS> <RETURN T>>
  54                                 <BLOCK <1 .LOBS>>
  55                                 <SET LOBS <REST .LOBS>>>
  56                         <SET NOB .OBLIST>
  57                         <SET UTOP <1 .NOB>>
  58                         <SET ROB (.UTOP !.NOB)>> >
  59
  60 <PUT ATOM O '<COND (<GASSIGNED? .IT> <O!-M <GLOC .IT>>)
  61                    (<ASSIGNED? .IT> <O!-M <LLOC .IT>>)
  62                    (ELSE '#FALSE ("UNASSIGNED"))>>
  63
  64
  65 <DEFINE UT () <O!-M .LOC!-M> <D>>
  66 \f<DEFINE PT () <PRIMP <IN .LOC!-M>> <AGAIN .RDBRAKEXIT>>
  67
  68 <DEFINE PA ("OPTIONAL" (N 0) "AUX" (QUICKPRINT!- #FALSE ()) (RI <- <* .N 3> 2>))
  69         <PUTCURS>
  70         <PRIMP  <COND (<L? .RI 0> <COND (<EMPTY? .LST!-M> <1 .CO!-M>) (T .CO!-M)>)
  71                       (<G? .RI <- <LENGTH .LST!-M> 3>> <IN .LOC!-M>)
  72                       (ELSE <.RI .LST!-M>)>>
  73         <REMCURS>
  74         <AGAIN .RDBRAKEXIT>>
  75
  76 <DEFINE P ()
  77         <PRIMP <COND (<==? .CI!-M .CL+1!-M> '#FALSE ("RIGHT-EDGE")) (ELSE <.CI!-M .CO!-M>)>>
  78         <AGAIN .RDBRAKEXIT>>
  79
  80 <DEFINE PRIMP (NP)
  81         <COND (<GASSIGNED? EPRINT!->
  82                 <COND (<LOOKUP "MEDSW" <GET PP!- OBLIST>>)
  83                       (T <FLOAD "MEDPP" ">" "DSK" "MUDDLE">)>
  84                 <EPRINT!- .NP>
  85                 <SETG PRIMP ,EPRINT!->)
  86               (ELSE <PRINT .NP>)>>
  87
  88 <SET MEDDLE_CURSOR!- "/\\">
  89
  90 <DEFINE PUTCURS ()
  91         <COND   (<==? .CI!-M .CL+1!-M> <SET SPECAFT!- <REST .CO!-M <- .CI!-M 2>>>)
  92                 (ELSE <SET SPECBEF!- <REST .CO!-M <- .CI!-M 1>>>)>>
  93
  94 <DEFINE REMCURS () <SET SPECBEF <SET SPECAFT 0>>>
  95
  96 <DEFINE Q () <UNOB> <EXIT .MMEDACT "muddle">>
  97
  98 <DEFINE UNOB ()
  99         <REPEAT ()      <AND <EMPTY? .OBPDL> <RETURN T>>
 100                         <ENDBLOCK>
 101                         <SET OBPDL <REST .OBPDL 4>> >>
 102
 103 <DEFINE \v (ARG)
 104         <VALRET <COND (<==? <TYPE .ARG> STRING> .ARG) (ELSE <UNPARSE .ARG>)>>>
 105
 106 <DEFINE ? ("AUX" (FIL <OPEN "READ" "MEDCOM" ">" "DSK" "MUDDLE">))
 107         <COND (.FIL
 108                 <REPEAT () <PRINC <READCHR '<RETURN T> .FIL>>>
 109                 <CLOSE .FIL>
 110                 <AGAIN .RDBRAKEXIT>)
 111               (ELSE #FALSE("Where's my file???"))>>
 112
 113 <DEFINE HERE (ATM)
 114         <COND (<==? <TYPE .ATM> ATOM>
 115                 <SET .ATM <CHTYPE ((.OBLIST !.OBPDL) <GETC!-M>) OBANDCURS>>)
 116               (ELSE #FALSE ("ARG NOT ATOM"))>>
 117
 118 <DEFINE OB EOB ("TUPLE" BLOK)
 119         <REPEAT ((BLK .BLOK))
 120                 <AND <EMPTY? .BLK> <RETURN T>>
 121                 <PUT .BLK 1 <COND (<==? <TYPE <1 .BLK>> OBLIST> <1 .BLK>)
 122                                   (<GET <1 .BLK> OBLIST>)
 123                                   (ELSE <EXIT .EOB #FALSE ("ARG NOT OBLIST OR OBLIST NAME")>)>>
 124                 <SET BLK <REST .BLK>> >
 125         <SET OBPDL (.NOB .UTOP .ROB .OBLIST !.OBPDL)>
 126         <SET NOB (!.BLOK !<COND (<MEMQ <ROOT> .BLOK> '()) (ELSE (<ROOT>))>)>
 127         <BLOCK .NOB>
 128         <SET UTOP <1 .NOB>>
 129         <SET ROB (.TOB !.NOB)>
 130         <AGAIN .RDBRAKEXIT>>
 131
 132 <DEFINE EB ()
 133         <COND (<EMPTY? .OBPDL> #FALSE ("NO MORE BLOCKS"))
 134               (ELSE
 135                 <SET NOB <1 .OBPDL>>
 136                 <SET UTOP <2 .OBPDL>>
 137                 <SET ROB <3 .OBPDL>>
 138                 <SET OBPDL <REST .OBPDL 4>>
 139                 <ENDBLOCK>
 140                 <AGAIN .RDBRAKEXIT>)>>
 141
 142 <DEFINE OB? ()
 143         <REPEAT ((FOB .OBLIST))
 144                 <AND <EMPTY? .FOB> <AGAIN .RDBRAKEXIT>>
 145                 <TERPRI>
 146                 <PRIN1 <GET <1 .FOB> OBLIST>>
 147                 <SET FOB <REST .FOB>> >>
 148 \f<DEFINE V () <SET VERBSW <NOT .VERBSW>> T>
 149
 150 <DEFINE & () <AMPERSAND> <AGAIN .RDBRAKEXIT>>
 151
 152 <SETG CLOBOT <REST <IVECTOR 5 '(1)> 5>>
 153 <SETG FSLBOT <REST <IUVECTOR 5 -1> 5>>
 154
 155 <DEFINE AMPERSAND ()
 156         <COND (<FLATSIZE .CO!-M .CLLN>  <TERPRI>
 157                                         <BRACK OPENBRAK .CO!-M>
 158                                         <REPEAT ((IX 0))
 159                                                 <AND <==? <SET IX <+ .IX 1>> .CI!-M>
 160                                                         <PRINC "/\\">>
 161                                                 <AND <==? .IX .CL+1!-M> <RETURN T>>
 162                                                 <PRIN1 <.IX .CO!-M>>
 163                                                 <PRINC !" >>
 164                                         <BRACK CLOSEBRAK .CO!-M>)
 165               (ELSE
 166                <PROG ((CLOB ,CLOBOT) (FSL ,FSLBOT) FS BEGIN STOP
 167                         (LLN <COND (<GET OPENBRAK <TYPE .CO!-M>> .CLLN)
 168                                    (ELSE <- .CLLN 2 <FLATSIZE <TYPE .CO!-M> .CLLN>>)>))
 169                 <COND (<G? .CL+1!-M 5>
 170                         <COND (<L? .CI!-M 4> <SET BEGIN .CO!-M> <SET LLN <- .LLN 1>>)
 171                               (<L? <- .CL+1!-M .CI!-M> 4> <SET BEGIN <REST .CO!-M <- .CL+1!-M 5>>>
 172                                                           <SET LLN <- .LLN 4>>)
 173                               (ELSE <SET BEGIN <REST .CO!-M <- .CI!-M 3>>>
 174                                     <SET LLN <- .LLN 9>>)>
 175                         <SET STOP <REST .BEGIN <MIN 4 <LENGTH .BEGIN>>>>
 176                         <AND <L? <FSZ> .LLN> <RETURN <EP1>>>)
 177                       (ELSE <SET BEGIN .CO!-M>
 178                             <SET STOP <REST .CO!-M <- .CL+1!-M 1>>>
 179                             <AND <L? <FSZ> .LLN> <RETURN <EP1>>>)>
 180                 <REPEAT ()
 181                     <REPEAT ((FL <REST .FSL>) (VIC .FSL))
 182                         <COND (<G? <1 .FL> <1 .VIC>> <SET VIC .FL>)
 183                               (<EMPTY? <SET FL <REST .FL>>>
 184                                 <SET CLOB <PUT <BACK .CLOB> 1
 185                                             <REST .BEGIN <- <LENGTH .VIC> 1>>>>
 186                                 <SET FS <- .FS <1 .VIC> -4>>
 187                                 <PUT .VIC 1 4>
 188                                 <RETURN T>)>>
 189                     <AND <L? .FS .LLN> <EP1> <RETURN T>>>>)>>
 190
 191 <DEFINE FSZ ()
 192         <REPEAT ((OBJ <REST .BEGIN 0>))
 193                 <SET FSL <PUT <BACK .FSL> 1
 194                                 <COND (<FLATSIZE <1 .OBJ> .LLN>)
 195                                       (ELSE <SET CLOB <PUT <BACK .CLOB> 1 .OBJ>> 4)>>>
 196                 <AND <==? <SET OBJ <REST .OBJ>> .STOP> <RETURN <SET FS <+ !.FSL>>>>>>
 197
 198 <DEFINE EP1 ()
 199         <TERPRI>
 200         <BRACK OPENBRAK .CO!-M>
 201         <OR <==? .BEGIN .CO!-M> <PRINC "...& ">>
 202         <SET BEGIN <REST .BEGIN 0>>
 203         <REPEAT ((CP <REST .CO!-M <- .CI!-M 1>>))
 204                 <AND <==? .BEGIN .CP> <PRINC "/\\">>
 205                 <COND (<==? .BEGIN .STOP> <RETURN T>)
 206                       (<MEMQ .BEGIN .CLOB> <BRACK OPENBRAK <1 .BEGIN>>
 207                                            <PRINC !"&>
 208                                            <BRACK CLOSEBRAK <1 .BEGIN>>)
 209                       (ELSE <PRIN1 <1 .BEGIN>>)>
 210                 <PRINC !" >
 211                 <SET BEGIN <REST .BEGIN>>>
 212         <OR <EMPTY? .STOP> <PRINC "&...">>
 213         <BRACK CLOSEBRAK .CO!-M>>
 214
 215 <DEFINE BRACK (WHICH WHAT "AUX" (BK <GET .WHICH <TYPE .WHAT>>))
 216         <COND (.BK <PRINC .BK>)
 217               (<MEMQ <TYPE .WHAT> '![ATOM FIX FLOAT]>)
 218               (<==? .WHICH CLOSEBRAK> <PRINC <GET CLOSEBRAK <PRIMTYPE .WHAT> !"?>>)
 219               (ELSE
 220                <PRINC !"#>
 221                <PRIN1 <TYPE .WHAT>>
 222                <PRINC !" >
 223                <PRINC <GET OPENBRAK <PRIMTYPE .WHAT> !"?>>)>>
 224
 225 <PUT OPENBRAK LIST !"(>         <PUT CLOSEBRAK LIST !")>
 226 <PUT OPENBRAK FORM !"<>         <PUT CLOSEBRAK FORM !">>
 227 <PUT OPENBRAK VECTOR !"[>       <PUT CLOSEBRAK VECTOR !"]>
 228 <PUT OPENBRAK UVECTOR "![">     <PUT CLOSEBRAK UVECTOR "!]">
 229 <PUT OPENBRAK STRING !"">       <PUT CLOSEBRAK STRING !"">
 230 <PUT OPENBRAK TUPLE !"[>        <PUT CLOSEBRAK TUPLE !"]>
 231 <PUT OPENBRAK SEGMENT "!<">     <PUT CLOSEBRAK SEGMENT "!>">
 232 \f<DEFINE I ("ARGS" L) <I!-M .L>>
 233 <DEFINE C ('IT) <C!-M .IT> T>
 234 <DEFINE R ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
 235         <COND (<R!-M .N>) (T <SET CI!-M .OCI> #FALSE ("RIGHT-EDGE"))>>
 236 <DEFINE L ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
 237         <COND (<L!-M .N>) (T <SET CI!-M .OCI> #FALSE ("LEFT-EDGE"))>>
 238 <DEFINE B () <SET CI!-M .CL+1!-M>>
 239 <DEFINE F () <SET CI!-M 1>>
 240 <DEFINE K ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
 241         <COND (<L? .N 0> <L!-M <- .N>> <SET N <- .OCI .CI!-M>>)>
 242         <K!-M .N> >
 243 <DEFINE U ("OPTIONAL" (N 1)) <PRIMREP ,UL!-M .N>>
 244 <DEFINE D ("OPTIONAL" (N 1)) <PRIMREP ,DR!-M .N>>
 245 <DEFINE UR ("OPTIONAL" (N 1)) <PRIMREP ,UR!-M .N>>
 246 <DEFINE DL ("OPTIONAL" (N 1)) <PRIMREP ,DL!-M .N>>
 247 <DEFINE WR ("OPTIONAL" (N 1)) <PRIMREP ,WR!-M .N>>
 248 <DEFINE WL ("OPTIONAL" (N 1)) <PRIMREP ,WL!-M .N>>
 249
 250 <DEFINE PRIMREP (WHAT MANY "AUX" (OLDC <GETC!-M>))
 251         <REPEAT (T1)
 252                 <COND (<L? .MANY 1> <RETURN T>)
 253                       (<SET T1 <.WHAT>>)
 254                       (ELSE <NC!-M .OLDC> <RETURN .T1>)>
 255                 <SET MANY <- .MANY 1>> >>
 256
 257 <DEFINE S ('IT) <AND <PS .IT ,SR!-M> <R!-M 1>>>
 258 <DEFINE -S ('IT)<AND <PS .IT ,SL!-M>>>
 259
 260 <DEFINE PS (WHAT HOW "AUX" (T <GETC!-M>))
 261         <COND (<.HOW .WHAT>)
 262               (ELSE <NC!-M .T> #FALSE ("NOT-FOUND"))>>
 263
 264 <DEFINE C: (NTYP) <C!-M <SETYPE <.CI!-M .CO!-M> .NTYP>> T>
 265
 266 <DEFINE I: (NTYP "OPTIONAL" (N 1) "AUX" (T <G!-M .N>))
 267         <K .N>
 268         <I!-M (<SETYPE .T .NTYP>)>
 269         <L!-M 1>>
 270
 271 <DEFINE K: ("AUX" (T <G!-M 1>) LINS)
 272         <COND (<MONAD? <1 .T>> #FALSE ("NOT-STRUCTURED"))
 273               (ELSE  <SET LINS <LENGTH <1 .T>>> <K!-M 1> <I!-M <1 .T>> <L!-M .LINS>)>>
 274
 275 <DEFINE SETYPE (OBJ NTYPE)
 276         <COND (<MONAD? .OBJ> <SET OBJ (.OBJ)>)>
 277         <CHTYPE <APPLY ,<TYPEPRIM .NTYPE> !.OBJ> .NTYPE>>
 278
 279 <DEFINE SC ("OPTIONAL" COMM)
 280         <COND (<==? .CL+1!-M .CI!-M> #FALSE ("RIGHT-EDGE"))
 281               (<ASSIGNED? COMM> <PUT <REST .CO!-M <- .CI!-M 1>> COMMENT .COMM> "put.")
 282               (T <PUT <REST .CO!-M <- .CI!-M 1>> COMMENT> "Removed.")>>
 283 \f<DEFINE BK ("ARGS" L)
 284         <COND   (<==? .CI!-M .CL+1!-M> '#FALSE ("RIGHT-EDGE"))
 285                 (ELSE <C!-M <CHTYPE (M_B .L <.CI!-M .CO!-M>) FORM>>
 286                       "busted")>>
 287
 288 <DEFINE KB ()
 289         <UT>
 290         <REPEAT (SV)
 291                 <COND (<SR!-M M_B> <SET SV <3 .CO!-M>>
 292                                 <UL!-M> <C!-M .SV>)
 293                       (ELSE <RETURN 1>)>>
 294         <UT>
 295         "DONE">
 296
 297 <DEFINE M_B ("BIND" CENV 'DOLIST 'SAVE
 298                         "AUX"   (OUTCHAN ,OUTCHAN)
 299                                 (INCHAN ,INCHAN))
 300         <TERPRI>
 301         <PRINC "*BREAK*">
 302         <REPEAT ()  <COND (<EMPTY? .DOLIST> <RETURN T>)
 303                           (ELSE <TERPRI>
 304                                 <PRIN1 <1 .DOLIST>>
 305                                 <PRINC " = ">
 306                                 <PRIN1 <EVAL <1 .DOLIST> .CENV>>
 307                                 <SET DOLIST <REST .DOLIST>>)>>
 308         <LISTEN>
 309         <EVAL .SAVE .CENV>>
 310 \fMERDE!-
 311
 312 <DEFINE OMERDE () <COND (<ASSIGNED? RDBRAKEXIT> <AGAIN .RDBRAKEXIT>) ("Not in MEDDLE.")>>
 313
 314 <SETG GOFORM '<EXIT .RDBRAKEXIT "out of reader">>
 315
 316 <SETG SPECS ![
 317         !"              ;"SPACE"
 318         !"              ;"TAB"
 319         !"
 320                         ;"CARRIAGE-RETURN"
 321         !"\r             ;"LINE-FEED"
 322         !"\e             ;"ALTMODE"
 323 ]>
 324
 325 <SETG ALTGETTER <MEMQ !"\e ,SPECS>>
 326
 327 <DEFINE RDBRAK ("BIND" UENV COB "OPTIONAL" (NOB .OBLIST)
 328                         "AUX"   (TOB <MOBLIST TOB 1>)
 329                                 (ROB (.TOB !.NOB))
 330                                 (UTOP <1 .NOB>)
 331                                 FRST CMND FLIST EFLIST)
 332         <READCHR>       ;"FLUSH THE CRETINOUS INITIAL ALTMODE."
 333         <REPEAT RDBRAKEXIT ()
 334                 <SET MERDE <CLOSURE ,OMERDE RDBRAKEXIT>>
 335         P2GO    <TERPRI>
 336                 <PRINC !"*>
 337          P1GO   <COND (<==? <NEXTCHR> <1 ,ALTGETTER>>
 338                         <READCHR>
 339                         <AMPERSAND>
 340                         <GO P2GO>)>
 341                 <COND (<NOT <==? ATOM <TYPE <SET FRST <READ ,GOFORM .INCHAN .ROB>>>>>
 342                         <REPEAT ((TTOB <1 .TOB>))
 343                                 <AND <EMPTY? .TTOB> <RETURN T>>
 344                                 <INTERN <REMOVE <1 .TTOB>> .UTOP>
 345                                 <SET TTOB <REST .TTOB>>>
 346                         <PRINT <EVAL .FRST .UENV>>
 347                         <AND <==? <NEXTCHR> !"\e> <READCHR>>
 348                         <GO P2GO>)
 349                       (<NOT <SET CMND <OR <LOOKUP <SET FLIST <PNAME .FRST>> <1 .COB>>
 350                                           <LOOKUP .FLIST <2 .COB>>>>>
 351                         <AND <==? <OBLIST? .FRST> .TOB> <INTERN <REMOVE .FRST> .UTOP>>
 352                         <PRINT .FRST>
 353                         <GO P2GO>)>
 354                 <AND <==? <OBLIST? .FRST> .TOB> <REMOVE .FRST>>
 355                 <SET FLIST <SET EFLIST <FORM .CMND>>>
 356                 <REPEAT (TEM)
 357                         <COND (<SET TEM <MEMQ <NEXTCHR ,GOFORM> ,SPECS>>
 358                                 <READCHR>
 359                                 <AND <==? .TEM ,ALTGETTER> <RETURN T>>)
 360                               (ELSE <SET EFLIST <REST <PUTREST .EFLIST (<READ ,GOFORM>)>>>)>>
 361                 <COND (<SET FLIST <EVAL .FLIST>>)
 362                       (ELSE <PRIN1 .FLIST>)>
 363                 <AND .VERBSW <GO P1GO>>
 364                 <AMPERSAND>>>
 365
 366
 367 <ENDBLOCK>
 368
 369 <COND (<LOOKUP "XMED" <1 .OBLIST>> <SETG <LOOKUP "XMED" <1 .OBLIST>> ,XMED!-> <REMOVE XMED>)>
 370 \f\f\f\ 3\f