/pliant/language/type/text/str.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19  public 
 20    constant default_charset_is_utf8 true 
 21   
 22   
 23  function '+=' s e 
 24    arg_rw Str s ; arg Str e 
 25    strong_definition 
 26    # this is speedup only function 
 27    resize s:len+e:len 
 28    memory_copy e:characters (s:characters translate Char s:len-e:len) e:len 
 29   
 30   
 31  method s search_last pattern default -> position 
 32    arg Str pattern ; arg Int default position 
 33    position := default 
 34    var Address base := characters 
 35    while true 
 36      base := memory_search base (cast (s:characters translate Char s:len) Int).-.(cast base Int) pattern:characters pattern:len 
 37      if base=null 
 38        return 
 39      position := (cast base Int).-.(cast s:characters Int) 
 40      base := base translate Char 1     
 41   
 42   
 43  function replace s pattern with -> s2 
 44    arg Str pattern with s2 
 45    check pattern:len>0 
 46    if pattern:len=with:len 
 47      s2 := s 
 48      var Int := -1 
 49      while { := ((s2 i+s2:len) search pattern -(i+2))+(i+1) ; i<>(-1) } 
 50        memory_copy with:characters (s2:characters translate Char i) with:len 
 51    else 
 52      var Int := search pattern -1 
 53      if i>=0 
 54        s2 := (i)+with+(replace (i+pattern:len s:len) pattern with) 
 55      else 
 56        s2 := s 
 57   
 58  function repeat n pattern -> result 
 59    arg Int n ; arg Str pattern result 
 60    check n>=0 
 61    var Address buffer := memory_allocate n*pattern:len addressof:result 
 62    for (var Int i) n-1 
 63      memory_copy pattern:characters (buffer translate Char i*pattern:len) pattern:len 
 64    result set buffer n*pattern:len true 
 65   
 66  function reverse s -> result 
 67    arg Str result 
 68    var Int := len 
 69    var Address buffer := memory_allocate addressof:result 
 70    for (var Int i) l-1 
 71      memory_copy (s:characters translate Char l-1-i) (buffer translate Char i) 1 
 72    result set buffer true 
 73   
 74  function left s l p -> s2 
 75    arg Str s ; arg Int l ; arg Str s2 
 76    check p:len=1 
 77    if s:len<l 
 78      var Address buffer := memory_allocate addressof:s2 
 79      memory_copy s:characters buffer s:len 
 80      for (var Int i) s:len l-1 
 81        memory_copy p:characters (buffer translate Char i) Char:size 
 82      s2 set buffer true 
 83    else 
 84      s2 := s 
 85       
 86  function right s l p -> s2 
 87    arg Str s ; arg Int l ; arg Str s2 
 88    check p:len=1 
 89    if s:len<l 
 90      var Address buffer := memory_allocate addressof:s2 
 91      memory_copy s:characters (buffer translate Char l-s:len) s:len 
 92      for (var Int i) l-s:len-1 
 93        memory_copy p:characters (buffer translate Char i) Char:size 
 94      s2 set buffer true 
 95    else 
 96      s2 := s 
 97       
 98  function upper s -> s2 
 99    arg Str s2 
 100    s2 set (memory_allocate s:len addressof:s2) s:len true 
 101    for (var Int i) s:len-1 
 102      var Int := s:i:number 
 103      if n>="a":0:number and n<="z":0:number 
 104        := + ("A":0:number-"a":0:number) 
 105      s2 := character n 
 106   
 107  function lower s -> s2 
 108    arg Str s2 
 109    s2 set (memory_allocate s:len addressof:s2) s:len true 
 110    for (var Int i) s:len-1 
 111      var Int := s:i:number 
 112      if n>="A":0:number and n<="Z":0:number 
 113        := + ("a":0:number-"A":0:number) 
 114      s2 := character n 
 115   
 116   
 117  export '+=' '. search_last' replace repeat reverse left right upper lower 
 118   
 119   
 120 
 
 121   
 122   
 123  function from_string u s o may_skip skiped offset f -> status 
 124    arg_w Universal u ; arg Str o ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function f ; arg Status status 
 125    indirect 
 126     
 127   
 128  method s option_position name if_not_found -> p 
 129    arg Str s ; arg Str name ; arg Int if_not_found p 
 130    var Address start := characters 
 131    var Address stop := start translate Char s:len 
 132    while true 
 133      var Address id := memory_search start (cast stop Int).-.(cast start Int) name:characters name:len 
 134      if id=null 
 135        return if_not_found 
 136      var Address dq := memory_search start (cast stop Int).-.(cast start Int) "[dq]":characters 1 
 137      if dq=null or dq>id 
 138        if id=s:characters or not ((id translate Char -1) map Char):isidentcharacter 
 139          if (id translate Char name:len)=(s:characters translate Char s:len) or not ((id translate Char name:len) map Char):isidentcharacter 
 140            return (cast id Int).-.(cast s:characters Int) 
 141          else 
 142            start := id translate Char 1 
 143        else 
 144          start := id translate Char 1 
 145      else 
 146        start := dq translate Char 1 
 147        var CBool inside := true 
 148        while inside 
 149          var Address dq := memory_search start (cast stop Int).-.(cast start Int) "[dq]":characters 1 
 150          if dq=null 
 151            return if_not_found 
 152          var Address lb := memory_search start (cast stop Int).-.(cast start Int) "[lb]":characters 1 
 153          if lb=null or lb>dq 
 154            if (memory_search start (cast dq Int).-.(cast start Int) "[rb]":characters 1)<>null 
 155              return if_not_found 
 156            start := dq translate Char 1 
 157            inside := false 
 158          else 
 159            if (memory_search start (cast lb Int).-.(cast start Int) "[rb]":characters 1)<>null 
 160              return if_not_found 
 161            var Address rb := memory_search (lb translate Char 2) (cast stop Int).-.(cast lb Int)-"[rb]":characters 1 
 162            if rb=null 
 163              return if_not_found 
 164            start := rb translate Char 1 
 165   
 166  method s option_position name instance if_not_found -> p 
 167    arg Str s ; arg Str name ; arg Int instance if_not_found p 
 168    check instance>=0 
 169    var Int offset := -1 
 170    for (var Int i) instance 
 171      var Int next := (offset+s:len) option_position name if_not_found 
 172      if next=if_not_found 
 173        return if_not_found 
 174      else 
 175        offset += 1+next 
 176    := offset 
 177   
 178     
 179  method s option name -> b 
 180    arg Str s ; arg Str name ; arg CBool b 
 181    := (option_position name -1)<>(-1) 
 182   
 183   
 184  method s option_value name instance fun type default result 
 185    arg Str s ; arg Str name ; arg Int instance ; arg Function fun ; arg Type type ; arg Universal default ; arg_w Universal result 
 186    var Int := option_position name instance -1 
 187    if p=(-1) 
 188      type copy_instance addressof:default addressof:result 
 189      return 
 190    += name:len 
 191    while p<s:len and (s:p=" ":0 or s:p="[tab]":0) 
 192      += 1 
 193    if (from_string result (s:len) "" false (var Int skiped) (var Int offset) fun)=failure 
 194      type copy_instance addressof:default addressof:result 
 195   
 196  meta '. option' e 
 197    if e:size<or not (e:cast Str) or not (e:cast Str)  
 198      return 
 199    var Int := 2 
 200    var Link:Argument instance :> argument constant Int 0 
 201    if u<e:size and (e:cast Int) 
 202      instance :> e:result 
 203      += 1 
 204    if u>=e:size or (e:constant Type)=null 
 205      return 
 206    var Pointer:Type :> (e:constant Type) map Type 
 207    += 1 
 208    var Pointer:Function :> get_generic_method (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index 
 209    if addressof:f=null or addressof:f=addressof:(the_function '. from string' Universal Str Str CBool Int Int -> Status) 
 210      return 
 211    var Link:Argument :> new Argument 
 212    locate argument_constant 
 213    constant := entry_new t 
 214    from_string (d:constant map Universal) "" "" false (var Int skiped) (var Int offset) f 
 215    if u<e:size and (e:cast t) 
 216      :> e:result 
 217      += 1 
 218    if u<>e:size 
 219      return 
 220    for (var Int i) e:size-1 
 221      suckup e:i 
 222    var Link:Argument :> argument local t 
 223    add (instruction (the_function '. option_value' Str Str Int Function Type Universal Universal) e:0:result e:1:result instance (argument mapped_constant Function f) (argument mapped_constant Type t) r) 
 224    set_result access_read 
 225      
 226  export '. option_position' '. option' 
 227   
 228   
 229 
 
 230   
 231   
 232  (gvar Array string_encoding) 'size :=' 256 
 233  gvar Dictionary string_decoding 
 234   
 235  function define_char_encoding char encoded 
 236    arg Int char ; arg Str encoded 
 237    var Link:Str :> new Str ; := encoded 
 238    string_encoding char := addressof e 
 239    var Link:Char :> new Char ; := character char 
 240    string_decoding insert encoded true addressof:c 
 241   
 242  define_char_encoding "[lb]":0:number "[lb]lb[rb]" 
 243  define_char_encoding "[rb]":0:number "[lb]rb[rb]" 
 244  define_char_encoding "[dq]":0:number "[lb]dq[rb]" 
 245  define_char_encoding "[cr]":0:number "[lb]cr[rb]" 
 246  define_char_encoding "[lf]":0:number "[lb]lf[rb]" 
 247  define_char_encoding "[0]":0:number "[lb]0[rb]" 
 248   
 249   
 250  method data 'to string' options -> string 
 251    arg Str data ; arg Str options ; arg Str string 
 252    if options="raw" or options="db" or options="con" 
 253      string := data 
 254    else 
 255      string := "[dq]"+data+"[dq]" 
 256      var Int := 1 
 257      while i<string:len-1 
 258        var Int ch := string:number 
 259        if string_encoding:ch<>null 
 260          var Pointer:Str :> string_encoding:ch map Str 
 261          string := (string i)+e+(string i+string:len) 
 262          := i+e:len 
 263        else 
 264          := i+1 
 265   
 266   
 267  method data 'from string' string options may_skip skiped offset -> status 
 268    arg_w Str data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 269    if options="raw" or options="db" or options="con" 
 270      data := string 
 271      skiped := 0 
 272      offset := string len 
 273      return success 
 274    var Int stop := string:len-1 
 275    if not may_skip and stop<>(-1) 
 276      stop := 0 
 277    for (var Int i) stop 
 278      var Int ci := string:number 
 279      if ci="[dq]":0:number 
 280        skiped := i 
 281        var Address cursor := string:characters translate Char i+1 
 282        var Int remain := string:len-(i+1) 
 283        var Address dq := memory_search cursor remain "[dq]":characters 1 
 284        var Address lb := memory_search cursor remain "[lb]":characters 1 
 285        if dq<>null and (lb=null or dq<lb) 
 286          # the string to decode does not contain any [ character 
 287          var Int := (cast dq Int).-.(cast cursor Int) 
 288          if (memory_search cursor "[rb]":characters 1)=null 
 289            data set (memory_allocate addressof:data) true 
 290            memory_copy cursor data:characters l 
 291            offset := (cast dq Int) .+. .-. (cast string:characters Int) 
 292            return success 
 293          else 
 294            # the string contains an unmatched ] character 
 295            return failure 
 296        var Address buf := memory_allocate remain null 
 297        var Address := buf 
 298        var CBool ok := true 
 299        while ok 
 300          var Int remain := (cast string:characters Int).+.string:len.-.(cast cursor Int) 
 301          var Address dq := memory_search cursor remain "[dq]":characters 1 
 302          if dq=null 
 303            # no " character: this is not a valid string 
 304            ok := false 
 305          else 
 306            var Address lb := memory_search cursor remain "[lb]":characters 1 
 307            if lb=null or dq<lb 
 308              # no more [ character 
 309              var Int := (cast dq Int).-.(cast cursor Int) 
 310              if (memory_search cursor "[rb]":characters 1)=null 
 311                # store the remaining not encoded characters and successfully returns 
 312                memory_copy cursor n ; := translate Char n 
 313                var Int := (cast Int).-.(cast buf Int) 
 314                data set (memory_allocate addressof:data) true 
 315                memory_copy buf data:characters l 
 316                memory_free buf 
 317                offset := (cast dq Int) .+. .-. (cast string:characters Int) 
 318                return success 
 319              else 
 320                # the string contains an unmatched ] character 
 321                ok := false 
 322            else 
 323              var Int := (cast lb Int).-.(cast cursor Int) 
 324              if (memory_search cursor "[rb]":characters 1)=null 
 325                # stores the charcters before the first [ : they are not encoded 
 326                memory_copy cursor n ; := translate Char n 
 327                var Address rb := memory_search (lb translate Char 2) (cast string:characters Int).+.string:len.-.(cast lb Int)-"[rb]":characters 1 
 328                if rb<>null 
 329                  (var Str sub) set lb (cast rb Int).-.(cast lb Int)+1 false 
 330                  # 'sub' is the encoded character 
 331                  var Pointer:Char ch :> (string_decoding first sub) map Char 
 332                  var Char c 
 333                  if addressof:ch<>null 
 334                    # we found it in the encoding dictionary 
 335                    := ch 
 336                  else 
 337                    := sub 1 
 338                    if c:number>="0":0:number and c:number<="9":0:number 
 339                      # we are looking for an integer between [ and ] 
 340                      var Int := 0 
 341                      for (var Int j) sub:len-2 
 342                        := sub:j 
 343                        if c:number>="0":0:number and c:number<="9":0:number 
 344                          := n*10+c:number-"0":0:number 
 345                        else 
 346                          ok := false 
 347                      if n<256 
 348                        := character n 
 349                      else 
 350                        ok := false 
 351                    eif sub:len=and not (c:number>="a":0:number and c:number<="z":0:number) and not (c:number>="A":0:number and c:number<="Z":0:number) 
 352                      # we have a single character in the middle, and it's neither a letter nor a number, so we decode it as itself 
 353                      void 
 354                    else 
 355                      # this is an unsupported encoding 
 356                      ok := false 
 357                  map Char := c 
 358                  := translate Char 1 
 359                  cursor := lb translate Char sub:len 
 360                else 
 361                  # unmatched [ character 
 362                  ok := false 
 363              else 
 364                # unmatched ] character 
 365                ok := false 
 366        # if we get there, then ok=false, so free the temporary storage area and return 
 367        memory_free buf 
 368        data := "" 
 369        return failure 
 370    data := "" 
 371    status := failure 
 372   
 373   
 374 
 
 375   
 376   
 377  type StrMatch 
 378    field Address current 
 379    field Address stop 
 380    field Address start 
 381    field CBool exact 
 382   
 383   
 384  method sm setup s exact 
 385    arg_w StrMatch sm ; arg Str s ; arg CBool exact 
 386    sm start := characters 
 387    sm current := sm start 
 388    sm stop := s:characters translate Char s:len 
 389    sm exact := exact 
 390     
 391  ((the_function '. setup' StrMatch Str CBool) arg 0):maps := 2 
 392   
 393   
 394  method sm drop_spaces 
 395    arg_rw StrMatch sm 
 396    while sm:current<>sm:stop and { var Char := sm:current map Char ; c=" ":0 or c="[tab]":0 } 
 397      sm current := sm:current translate Char 1 
 398   
 399  method sm conditional_drop_spaces 
 400    arg_rw StrMatch sm 
 401    if not sm:exact 
 402      sm drop_spaces 
 403   
 404  method s drop_end_spaces 
 405    arg_rw Str s 
 406    var Int := s:len 
 407    if l<>and ( (l-1)=" ":0 or (l-1)="[tab]":0 ) 
 408      while l<>and (l-1)=" ":0 
 409        := l-1 
 410      resize l 
 411       
 412   
 413  method sm underscore -> ok 
 414    arg_rw StrMatch sm ; arg CBool ok 
 415    if sm:current=sm:stop 
 416      return false 
 417    var Char := sm:current map Char 
 418    sm current := sm:current translate Char 1 
 419    sm drop_spaces 
 420    ok := c=" ":0 or c="[tab]":0 
 421   
 422  method sm underscore s -> ok 
 423    arg_rw StrMatch sm ; arg_w Str s ; arg CBool ok 
 424    var Address cur := sm current 
 425    while sm:current<>sm:stop and { var Char := sm:current map Char ; c<>" ":0 and c<>"[tab]":0 } 
 426      sm current := sm:current translate Char 1 
 427    if sm:current=sm:stop 
 428      return false 
 429    var Int := (cast sm:current Int).-.(cast cur Int) 
 430    set (memory_allocate addressof:s) true 
 431    memory_copy cur s:characters l 
 432    sm drop_spaces 
 433    ok := true 
 434   
 435   
 436  method sm spaces sp -> ok 
 437    arg_rw StrMatch sm ; arg_w Str sp ; arg CBool ok 
 438    var Address cur := sm current 
 439    sm drop_spaces 
 440    var Int := (cast sm:current Int).-.(cast cur Int) 
 441    sp set (memory_allocate addressof:sp) true 
 442    memory_copy cur sp:characters l 
 443    ok := true 
 444   
 445  method sm spaces s sp -> ok 
 446    arg_rw StrMatch sm ; arg_w Str sp ; arg CBool ok 
 447    var Address cur := sm current 
 448    while sm:current<>sm:stop and { var Char := sm:current map Char ; c<>" ":0 and c<>"[tab]":0 } 
 449      sm current := sm:current translate Char 1 
 450    var Int := (cast sm:current Int).-.(cast cur Int) 
 451    set (memory_allocate addressof:s) true 
 452    memory_copy cur s:characters l 
 453    var Address cur := sm current 
 454    sm drop_spaces 
 455    var Int := (cast sm:current Int).-.(cast cur Int) 
 456    sp set (memory_allocate addressof:sp) true 
 457    memory_copy cur sp:characters l 
 458    ok := true 
 459   
 460   
 461  method sm pattern p -> ok 
 462    arg_rw StrMatch sm ; arg Str p ; arg CBool ok 
 463    check p:len>0 
 464    sm conditional_drop_spaces 
 465    var Int := (cast sm:stop Int).-.(cast sm:current Int) 
 466    if l<p:len 
 467      return false 
 468    if (memory_different sm:current p:len p:characters p:len) 
 469      return false 
 470    sm current := sm:current translate Char p:len 
 471    ok := true 
 472   
 473  method sm pattern s p -> ok 
 474    arg_rw StrMatch sm ; arg_w Str s ; arg Str p ; arg CBool ok 
 475    sm conditional_drop_spaces 
 476    var Address := memory_search sm:current (cast sm:stop Int).-.(cast sm:current Int) p:characters p:len 
 477    if a=null 
 478      return false 
 479    var Int := (cast Int).-.(cast sm:current Int) 
 480    set (memory_allocate addressof:s) true 
 481    memory_copy sm:current s:characters l 
 482    if not sm:exact 
 483      drop_end_spaces 
 484    sm current := translate Char p:len 
 485    ok := true 
 486   
 487   
 488  method sm word p -> ok 
 489    arg_rw StrMatch sm ; arg Str p ; arg CBool ok 
 490    ok := sm pattern p 
 491    if sm:current<>sm:stop and (sm:current map Char):isidentcharacter 
 492      ok := false 
 493   
 494  method sm word s p -> ok 
 495    arg_rw StrMatch sm ; arg_w Str s ; arg Str p ; arg CBool ok 
 496    sm conditional_drop_spaces 
 497    var Address := memory_search sm:current (cast sm:stop Int).-.(cast sm:current Int) p:characters p:len 
 498    if a=null 
 499      return false 
 500    eif a<>sm:current and ((translate Char -1) map Char):isidentcharacter 
 501      return false 
 502    ok := (sm pattern p) 
 503    if sm:current<>sm:stop and (sm:current map Char):isidentcharacter 
 504      ok := false 
 505    
 506   
 507  function memory_acdifferent area1 size1 area2 size2 -> c 
 508    arg Address area1 ; arg Int size1 ; arg Address area2 ; arg Int size2 ; arg CBool c 
 509    # unefficient implementation 
 510    (var Str s1) set area1 size1 false 
 511    (var Str s2) set area2 size2 false 
 512    := lower:s1<>lower:s2 
 513   
 514  method sm acpattern p -> ok 
 515    arg_rw StrMatch sm ; arg Str p ; arg CBool ok 
 516    check p:len>0 
 517    sm conditional_drop_spaces 
 518    var Int := (cast sm:stop Int).-.(cast sm:current Int) 
 519    if l<p:len 
 520      return false 
 521    if (memory_acdifferent sm:current p:len p:characters p:len) 
 522      return false 
 523    sm current := sm:current translate Char p:len 
 524    ok := true 
 525   
 526  function memory_acsearch address size pattern_address pattern_size -> p 
 527    arg Address address ; arg Int size ; arg Address pattern_address ; arg Int pattern_size ; arg Address p 
 528    # unefficient implementation 
 529    (var Str s) set address size false 
 530    (var Str pattern) set pattern_address pattern_size false 
 531    var Int := lower:search lower:pattern -1 
 532    if i<>(-1) 
 533      := address translate Byte i 
 534    else 
 535      := null 
 536   
 537  method sm acpattern s p -> ok 
 538    arg_rw StrMatch sm ; arg_w Str s ; arg Str p ; arg CBool ok 
 539    sm conditional_drop_spaces 
 540    var Address := memory_acsearch sm:current (cast sm:stop Int).-.(cast sm:current Int) p:characters p:len 
 541    if a=null 
 542      return false 
 543    var Int := (cast Int).-.(cast sm:current Int) 
 544    set (memory_allocate addressof:s) true 
 545    memory_copy sm:current s:characters l 
 546    if not sm:exact 
 547      drop_end_spaces 
 548    sm current := translate Char p:len 
 549    ok := true 
 550   
 551   
 552  method sm acword p -> ok 
 553    arg_rw StrMatch sm ; arg Str p ; arg CBool ok 
 554    ok := sm acpattern p 
 555    if sm:current<>sm:stop and (sm:current map Char):isidentcharacter 
 556      ok := false 
 557   
 558  method sm acword s p -> ok 
 559    arg_rw StrMatch sm ; arg_w Str s ; arg Str p ; arg CBool ok 
 560    sm conditional_drop_spaces 
 561    var Address := memory_acsearch sm:current (cast sm:stop Int).-.(cast sm:current Int) p:characters p:len 
 562    if a=null 
 563      return false 
 564    eif a<>sm:current and ((translate Char -1) map Char):isidentcharacter 
 565      return false 
 566    ok := (sm acpattern p) 
 567    if sm:current<>sm:stop and (sm:current map Char):isidentcharacter 
 568      ok := false 
 569    
 570   
 571   
 572   
 573  method sm from_string u f -> ok 
 574    arg_rw StrMatch sm ; arg_w Universal u ; arg Function f ; arg CBool ok 
 575    sm conditional_drop_spaces 
 576    (var Str string) set sm:current (cast sm:stop Int).-.(cast sm:current Int) false 
 577    if (from_string string "" false (var Int skiped) (var Int offset) f)=success 
 578      sm:current := sm:current translate Byte offset 
 579      ok := true 
 580    else 
 581      ok := false 
 582   
 583  method sm from_string s u f -> ok 
 584    arg_rw StrMatch sm ; arg_w Str s ; arg_w Universal u ; arg Function f ; arg CBool ok 
 585    sm conditional_drop_spaces 
 586    (var Str string) set sm:current (cast sm:stop Int).-.(cast sm:current Int) false 
 587    if (from_string string "" true (var Int skiped) (var Int offset) f)=success 
 588      set sm:current skiped false     
 589      sm:current := sm:current translate Byte offset 
 590      ok := true 
 591    else 
 592      ok := false 
 593   
 594   
 595  method sm offset i 
 596    arg_rw StrMatch sm ; arg_w Int i 
 597    := (cast sm:current Int).-.(cast sm:start Int) 
 598   
 599   
 600  method sm conclude initial -> ok 
 601    arg_rw StrMatch sm ; arg Str initial ; arg CBool ok 
 602    sm conditional_drop_spaces 
 603    ok := sm:current=sm:stop 
 604   
 605  method sm conclude s initial -> ok 
 606    arg_rw StrMatch sm ; arg_w Str s ; arg Str initial ; arg CBool ok 
 607    sm conditional_drop_spaces 
 608    var Int := (cast sm:stop Int).-.(cast sm:current Int) 
 609    var Address := memory_allocate addressof:s 
 610    memory_copy sm:current l 
 611    set true 
 612    if not sm:exact 
 613      drop_end_spaces 
 614    ok := true 
 615   
 616  # initial is used to prevent the matched string to be reused as a temporary string 
 617  if ((the_function '. conclude' StrMatch Str -> CBool):flags .and. function_flag_inline_instructions)<>or ((the_function '. conclude' StrMatch Str Str -> CBool):flags .and. function_flag_inline_instructions)<>0 
 618    error_notify error_id_unexpected null "conclude is inline !!!" 
 619   
 620   
 621  function try_match e exact 
 622    arg_rw Expression e ; arg CBool exact 
 623    if e:size<or not (e:cast Str) 
 624      return 
 625    var Link:Argument sm :> argument local StrMatch 
 626    var Link:Argument ok :> argument local CBool 
 627    var Link:Instruction end :> instruction the_function:'do nothing' 
 628    var Pointer:Argument :> null map Argument 
 629    suckup e:0 
 630    add (instruction (the_function '. setup' StrMatch Str CBool) sm e:0:result (argument constant CBool exact)) 
 631    for (var Int i) e:size-1 
 632      if addressof:(entry_type e:i:value)=addressof:Str or addressof:(entry_type e:i:value)=addressof:Char 
 633        var Str pattern 
 634        if addressof:(entry_type e:i:value)=addressof:Str 
 635          pattern := e:i:value map Str 
 636        else 
 637          pattern := e:i:value map Char 
 638        if addressof:s=null 
 639          add (instruction (the_function '. pattern' StrMatch Str -> CBool) sm (argument constant Str pattern) ok) 
 640        else       
 641          add (instruction (the_function '. pattern' StrMatch Str Str -> CBool) sm s (argument constant Str pattern) ok) 
 642          :> null map Argument         
 643        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 644      eif e:i:ident="_" and e:i:size=0 
 645        if addressof:s=null 
 646          add (instruction (the_function '. underscore' StrMatch -> CBool) sm ok) 
 647        else       
 648          add (instruction (the_function '. underscore' StrMatch Str -> CBool) sm ok) 
 649          :> null map Argument         
 650        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 651      eif e:i:ident="spaces" and e:i:size=and (e:i:cast Str) 
 652        suckup e:i:0 
 653        if addressof:s=null 
 654          add (instruction (the_function '. spaces' StrMatch Str -> CBool) sm e:i:0:result ok) 
 655        else       
 656          add (instruction (the_function '. spaces' StrMatch Str Str -> CBool) sm e:i:0:result ok) 
 657          :> null map Argument         
 658        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 659      eif e:i:ident="pattern" and e:i:size=and (e:i:cast Str) 
 660        suckup e:i:0 
 661        if addressof:s=null 
 662          add (instruction (the_function '. pattern' StrMatch Str -> CBool) sm e:i:0:result ok) 
 663        else       
 664          add (instruction (the_function '. pattern' StrMatch Str Str -> CBool) sm e:i:0:result ok) 
 665          :> null map Argument         
 666        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 667      eif e:i:ident="word" and e:i:size=and (e:i:cast Str) 
 668        suckup e:i:0 
 669        if addressof:s=null 
 670          add (instruction (the_function '. word' StrMatch Str -> CBool) sm e:i:0:result ok) 
 671        else       
 672          add (instruction (the_function '. word' StrMatch Str Str -> CBool) sm e:i:0:result ok) 
 673          :> null map Argument         
 674        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 675      eif e:i:ident="acpattern" and e:i:size=and (e:i:cast Str) 
 676        suckup e:i:0 
 677        if addressof:s=null 
 678          add (instruction (the_function '. acpattern' StrMatch Str -> CBool) sm e:i:0:result ok) 
 679        else       
 680          add (instruction (the_function '. acpattern' StrMatch Str Str -> CBool) sm e:i:0:result ok) 
 681          :> null map Argument         
 682        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 683      eif e:i:ident="acword" and e:i:size=and (e:i:cast Str) 
 684        suckup e:i:0 
 685        if addressof:s=null 
 686          add (instruction (the_function '. acword' StrMatch Str -> CBool) sm e:i:0:result ok) 
 687        else       
 688          add (instruction (the_function '. acword' StrMatch Str Str -> CBool) sm e:i:0:result ok) 
 689          :> null map Argument         
 690        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 691      eif e:i:ident="any" and e:i:size=and addressof:s=null 
 692        :> argument local Str 
 693      eif e:i:ident="any" and e:i:size=and (e:i:cast Str) and addressof:s=null 
 694        suckup e:i:0 
 695        :> e:i:0:result 
 696      eif e:i:ident="offset" and e:i:size=and (e:i:cast Int) and addressof:s=null 
 697        suckup e:i:0 
 698        add (instruction (the_function '. offset' StrMatch Int) sm e:i:0:result) 
 699      eif { e:compile ; (addressof e:i:result)<>null } and { var Pointer:Function function :> e:i:result:type get_generic_method (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index ; addressof:function<>null and addressof:function<>addressof:(the_function '. from string' Universal Str Str CBool Int Int -> Status) } 
 700        suckup e:i 
 701        if addressof:s=null 
 702          add (instruction (the_function '. from_string' StrMatch Universal Function -> CBool) sm e:i:result (argument mapped_constant Function function) ok) 
 703        else       
 704          add (instruction (the_function '. from_string' StrMatch Str Universal Function -> CBool) sm e:i:result (argument mapped_constant Function function) ok) 
 705          :> null map Argument         
 706        add (instruction (the_function 'jump if not' CBool) ok jump end) 
 707      else 
 708        return 
 709    if addressof:s=null 
 710      add (instruction (the_function '. conclude' StrMatch Str -> CBool) sm e:0:result ok) 
 711    else       
 712      add (instruction (the_function '. conclude' StrMatch Str Str -> CBool) sm e:0:result ok) 
 713    add end   
 714    set_result ok access_read 
 715   
 716  meta '. parse' e 
 717    try_match false 
 718   
 719  meta '. eparse' e 
 720    try_match true 
 721   
 722  export '. parse' '. eparse' 
 723   
 724   
 725 
 
 726   
 727   
 728  constant to_index (the_function '. to string' Universal Str -> Str):generic_index 
 729   
 730  function to_string data options function -> string 
 731    arg Universal data ; arg Str options ; arg Function function ; arg Str string 
 732    indirect 
 733     
 734  meta string e 
 735    if e:size<or e:size>2 
 736      return 
 737    e:0:compile ? 
 738    if e:size=and not (e:cast Str) 
 739      return 
 740    var Pointer:Type type :> e:0:result:type:real_data_type 
 741    var Pointer:Function function :> type get_generic_method to_index 
 742    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str) 
 743      return 
 744    e:cast type ? 
 745    suckup e:0 
 746    var Link:Argument options 
 747    if e:size=2 
 748      suckup e:1 
 749      options :> e:1:result 
 750    else 
 751      options :> argument constant Str "" 
 752    var Link:Argument result :> argument local Str 
 753    add (instruction (the_function to_string Universal Str Function -> Str) e:0:result options (argument mapped_constant Function function) result) 
 754    set_result result access_read 
 755   
 756  export string