mim/development/mim/vax/mimlib/nstr.mud

   1 <PACKAGE "NSTR">
   2
   3 "This package contains the useful stuff in the old STR package, rewritten
   4 in Muddle instead of assembly code."
   5
   6 <ENTRY SUBSTR SUBSNC UPPERCASE SIXTOS STRTOX LOWERCASE>
   7
   8 "STRTOX -- String to Sixbit, takes a string and returns a single-word sixbit
   9 representation of it"
  10
  11 <DEFINE STRTOX (STR "AUX" (W 0) (CNT 0) C)
  12         #DECL ((STR) STRING (W) <PRIMTYPE WORD> (CNT C) FIX)
  13         <REPEAT ()
  14                 <COND (<EMPTY? .STR> <SET C 0>)
  15                       (<G? <SET C <C2I <1 .STR>>> 31>
  16                        <REPEAT ()
  17                                <SET C <- .C 32>>
  18                                <COND (<L? .C 64> <RETURN>)>>)
  19                       (ELSE <SET C 0>)>
  20                 <SET W <ORB <LSH .W 6> .C>>
  21                 <COND (<==? <SET CNT <+ .CNT 1>> 6> <RETURN .W>)>
  22                 <OR <EMPTY? .STR> <SET STR <REST .STR>>>>>
  23
  24 "SIXTOS -- Sixbit to String, takes a sixbit word and returns the string
  25 corresponding to it.  Note that trailing sixbit spaces are not put in the
  26 string returned."
  27
  28 <DEFINE SIXTOS (W "OPTIONAL" (Q <>))
  29         #DECL ((W) <PRIMTYPE WORD> (Q) <OR CHARACTER FALSE>)
  30         <MAPF ,STRING
  31               <FUNCTION ("AUX" C)
  32                       #DECL ((C) <PRIMTYPE FIX>)
  33                       <AND <0? <CHTYPE .W FIX>> <MAPSTOP>>
  34                       <SET W <ROT .W 6>>
  35                       <SET C <I2C <+ <ANDB .W 63> 32>>>
  36                       <SET W <ANDB .W -64>>
  37                       <COND (<AND .Q <MEMQ .C " :;">>
  38                              <MAPRET .Q .C>)
  39                             (.C)>>>>
  40
  41 "CHARACTER <-> FIX : Faster than ASCII."
  42
  43 <DEFMAC I2C ('I) <FORM CHTYPE .I CHARACTER>>
  44
  45 <DEFMAC C2I ('C) <FORM CHTYPE .C FIX>>
  46
  47 "SUBSTR -- Substring search, takes arguments such as MEMQ and optionally a maximum
  48 length to search and a flag indicating whether case is to be considered
  49 significant"
  50
  51 <DEFINE SUBSTR (S1 S2 "OPTIONAL" (N <LENGTH .S2>) (CASE? T)
  52                 "AUX" (S .S1) (WIN <>) (CNT 0) C)
  53         #DECL ((S S1 S2) STRING (WIN) <OR STRING FALSE> (N CNT) FIX (C) CHARACTER)
  54         <MAPR <>
  55               <FUNCTION (S2)
  56                   #DECL ((S2) STRING)
  57                   <COND (<G? <SET CNT <+ .CNT 1>> .N> <MAPLEAVE <>>)
  58                         (<OR <==? <1 .S> <SET C <1 .S2>>>
  59                              <AND <NOT .CASE?>
  60                                   <==? <COND (<AND <G=? <C2I .C> <C2I !\a>>
  61                                                    <L=? <C2I .C> <C2I !\z>>>
  62                                               <I2C <- <C2I .C> 32>>)
  63                                              (ELSE .C)>
  64                                        <COND (<AND <G=? <C2I <1 .S>> <C2I !\a>>
  65                                                    <L=? <C2I <1 .S>> <C2I !\z>>>
  66                                               <I2C <- <C2I <1 .S>> 32>>)
  67                                              (ELSE <1 .S>)>>>>
  68                          <OR .WIN <SET WIN .S2>>
  69                          <COND (<EMPTY? <SET S <REST .S>>>
  70                                 <MAPLEAVE .WIN>)>)
  71                         (ELSE
  72                          <SET S .S1>
  73                          <SET WIN <>>)>>
  74               .S2>>
  75
  76 "SUBSNC -- Substring No Case, encapsulates SUBSTR with a fourth arg of <>"
  77
  78 <DEFINE SUBSNC (S1 S2 "OPTIONAL" (N <LENGTH .S2>))
  79         #DECL ((S1 S2) STRING (N) FIX)
  80         <SUBSTR .S1 .S2 .N <>>>
  81
  82 "UPPERCASE -- Uppercases a string, clobbers the old string."
  83
  84 <DEFINE UPPERCASE (S "OPTIONAL" (CNT <LENGTH .S>))
  85         #DECL ((S) STRING (CNT) FIX)
  86         <REPEAT ((S .S))
  87                 #DECL ((S) STRING)
  88                 <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)
  89                       (<AND <G=? <C2I <1 .S>> <C2I !\a>>
  90                             <L=? <C2I <1 .S>> <C2I !\z>>>
  91                        <PUT .S 1 <I2C <- <C2I <1 .S>> 32>>>)>
  92                 <SET S <REST .S>>>
  93         .S>
  94
  95 "LOWERCASE -- Lowercases a string, clobbers the old string."
  96
  97 <DEFINE LOWERCASE (S "OPTIONAL" (CNT <LENGTH .S>))
  98         #DECL ((S) STRING (CNT) FIX)
  99         <REPEAT ((S .S))
 100                 #DECL ((S) STRING)
 101                 <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)
 102                       (<AND <G=? <C2I <1 .S>> <C2I !\A>>
 103                             <L=? <C2I <1 .S>> <C2I !\Z>>>
 104                        <PUT .S 1 <I2C <+ <C2I <1 .S>> 32>>>)>
 105                 <SET S <REST .S>>>
 106         .S>
 107
 108 <ENDPACKAGE>