home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / program / m2posx02 / lib.ipp < prev    next >
Text File  |  1993-10-23  |  46KB  |  1,417 lines
  1. IMPLEMENTATION MODULE lib;
  2. (*__NO_CHECKS__*)
  3. (*****************************************************************************)
  4. (* "fnmatch()":                                                              *)
  5. (* Als Grundlage dienten die 'C'-Dateien 'glob.c' der GNU-Shell BASH und     *)
  6. (* 'fnmatch.c/h' der GNU-Fileutils; das vorliegende Modul hat jedoch nur     *)
  7. (* noch wenig Aehnlichkeit. Insbesondere die Behandlung der Flags fuer den   *)
  8. (* fuehrenden Punkt bei Dateinamen und den Verzeichnistrenner ist anders     *)
  9. (* geloest, da neben mindestens einem wirklichen Fehler in 'fnmatch.c' meh-  *)
  10. (* rere Stellen vorhanden sind, an denen mir nicht klar ist, ob dort nun     *)
  11. (* ein Fehler vorliegt, oder ob das tatsaechlich so gemeint war. Leider      *)
  12. (* kenne ich die "POSIX"-Definitionen fuer ``fnmatch'' nicht.                *)
  13. (* Meiner Meinung nach sind bei dem Versuch die Rekursion im '*'-Fall auf-   *)
  14. (* zuloesen, einige Kombinationen auf der Strecke geblieben.                 *)
  15. (* Aber sicherlich habe ich auch noch eigene Fehler eingebaut...             *)
  16. (*                                                                           *)
  17. (* Die Funktion "rand()" ist eine direkte Umsetzung aus der GnuLib/MiNTLib.  *)
  18. (*---------------------------------------------------------------------------*)
  19. (* STATUS: OK                                                                *)
  20. (*---------------------------------------------------------------------------*)
  21. (* 12-Feb-93, Holger Kleinschmidt                                            *)
  22. (*****************************************************************************)
  23.  
  24. VAL_INTRINSIC
  25. CAST_IMPORT
  26. PTR_ARITH_IMPORT
  27. INLINE_CODE_IMPORT
  28.  
  29. FROM SYSTEM IMPORT
  30. (* TYPE *) ADDRESS,
  31. (* PROC *) ADR;
  32.  
  33. FROM types IMPORT
  34. (* CONST*) NULL, XDIRSEP,
  35. (* TYPE *) UNSIGNEDLONG, SIGNEDLONG;
  36.  
  37. FROM CTYPE IMPORT
  38. (* PROC *) TODIGIT, TOCARD, TOUPPER, ISSPACE;
  39.  
  40. FROM pSTRING IMPORT
  41. (* CONST*) EOS,
  42. (* PROC *) SLEN, ASSIGN;
  43.  
  44. FROM err IMPORT
  45. (* CONST*) eOK, eRROR, eDRVNR, eUNCMD, eCRC, eBADRQ, eSEEK, eMEDIA, eSECNF,
  46.            ePAPER, eWRITF, eREADF, eGENRL, eWRPRO, eCHNG, eUNDEV, eBADSF,
  47.            eOTHER, eINSERT, eDVNRSP, eINVFN, eFILNF, ePTHNF, eNHNDL, eACCDN,
  48.            eIHNDL, eNSMEM, eIMBA, eDRIVE, eNSAME, eNMFIL, eLOCKED, eNSLOCK,
  49.            eRANGE, eINTRN, ePLFMT, eGSBF,
  50.            E2BIG, EAGAIN, EBUSY, EDEADLK, EDOM, EEXIST, EFBIG, EINTR, EINVAL,
  51.            EISDIR, EMLINK, ENAMETOOLONG, ENOLCK, ENOSPC, ENOTEMPTY, ENOTTY,
  52.            EPIPE, ERANGE, ESPIPE, ELOOP,
  53. (* VAR  *) errno;
  54.  
  55. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  56.  
  57. CONST
  58.   MINLINT  = 80000000H;
  59.   MAXLINT  = 7FFFFFFFH;
  60.   MAXLCARD = 0FFFFFFFFH;
  61.  
  62. VAR
  63.   Seed : SIGNEDLONG;
  64.  
  65. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  66.  
  67. PROCEDURE bswap ((* EIN/ -- *) blk1 : ADDRESS;
  68.                  (* EIN/ -- *) blk2 : ADDRESS;
  69.                  (* EIN/ -- *) len  : UNSIGNEDLONG );
  70. (*T*)
  71. (* Die Prozedur veraendert nur die Register D0/D1 und A0/A1.
  72.  * Dies sollte fuer die gaengigen M2-Compiler ausreichen. Falls
  73.  * weitere Register gerettet werden muessen, koennen die
  74.  * einkommentierten Inline-Sequenzen benutzt werden, ohne dass
  75.  * der restliche Code geaendert werden muss.
  76.  *)
  77. BEGIN
  78.  SETREG(8, blk1);
  79.  SETREG(9, blk2);
  80.  SETREG(0, len);
  81. (*
  82. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  83. /* keine Register retten */
  84. #elif HM2
  85.   move.w  D2,-(SP)
  86. #else
  87.   movem.l D1/D2/A0/A1,-(SP)
  88. #endif
  89.   tst.l   D0
  90.   beq.s   ende
  91.   move.w  A0,D1
  92.   move.w  A1,D2
  93.   eor.b   D2,D1          ; genau eine der Adressen ungerade ?
  94.   btst    #0,D1          ;
  95.   beq.s   fastswap       ; B: nein
  96. slowswap:                ; Bloecke byteweise vertauschen
  97.   move.b  (A0),D1
  98.   move.b  (A1),(A0)+
  99.   move.b  D1,(A1)+
  100.   subq.l  #1,D0
  101.   bne.s   slowswap
  102.   bra.s   ende           ; fertig
  103.  
  104. fastswap:
  105.   btst    #0,D2          ; beide Adr. ungerade oder beide gerade ?
  106.   beq.s   longcnt        ; B: beide gerade
  107.   move.b  (A0),D1        ; sonst ein Byte vorneweg tauschen
  108.   move.b  (A1),(A0)+     ; -> gerade Adresse
  109.   move.b  D1,(A1)+
  110.   subq.l  #1,D0          ; eins weniger zu tauschen
  111. longcnt:
  112.   move.b  D0,D2          ; fuer spaeteren Ueberhangtest
  113.   lsr.l   #2,D0          ; Anzahl auszutauschender Langworte
  114.   beq.s   tstwswap       ; B: weniger als 4 Byte
  115. swaplp:                  ; Bloecke langwortweise vertauschen
  116.   move.l  (A0),D1
  117.   move.l  (A1),(A0)+
  118.   move.l  D1,(A1)+
  119.   subq.l  #1,D0
  120.   bne.s   swaplp
  121. tstwswap:
  122.   btst    #1,D2          ; noch ein zusaetzl. Wort auszutauschen ?
  123.   beq.s   tstbswap       ; B: nein
  124.   move.w  (A0),D1
  125.   move.w  (A1),(A0)+
  126.   move.w  D1,(A1)+
  127. tstbswap:
  128.   btst    #0,D2          ; noch ein Byte ?
  129.   beq.s   ende           ; B: nein, fertig
  130.   move.b  (A0),D1
  131.   move.b  (A1),(A0)
  132.   move.b  D1,(A1)
  133. ende:
  134. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  135. /* keine Register retten */
  136. #elif HM2
  137.   move.w  (SP)+,D2
  138. #else
  139.   movem.l (SP)+,D1/D2/A0/A1
  140. #endif
  141.  
  142. *)
  143. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  144. /* */
  145. #elif HM2
  146.  CODE(3F02H);
  147. #else
  148.  CODE(48E7H,40C0H);
  149. #endif
  150.  CODE(4A80H,674EH,3208H,3409H,0B501H,0801H,0000H);
  151.  CODE(670CH,1210H,10D1H,12C1H,5380H,66F6H,6036H,0802H);
  152.  CODE(0000H,6708H,1210H,10D1H,12C1H,5380H,1400H,0E488H);
  153.  CODE(670AH,2210H,20D1H,22C1H,5380H,66F6H,0802H,0001H);
  154.  CODE(6706H,3210H,30D1H,32C1H,0802H,0000H,6706H,1210H);
  155.  CODE(1091H,1281H);
  156. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  157. /* */
  158. #elif HM2
  159.  CODE(341FH);
  160. #else
  161.  CODE(4CDFH,0302H);
  162. #endif
  163. END bswap;
  164.  
  165. (*---------------------------------------------------------------------------*)
  166.  
  167. PROCEDURE bcopy ((* EIN/ -- *) src : ADDRESS;
  168.                  (* EIN/ -- *) dst : ADDRESS;
  169.                  (* EIN/ -- *) len : UNSIGNEDLONG );
  170. (*T*)
  171. (* Die Prozedur veraendert nur die Register D0/D1 und A0/A1.
  172.  * Dies sollte fuer die gaengigen M2-Compiler ausreichen. Falls
  173.  * weitere Register gerettet werden muessen, koennen die
  174.  * einkommentierten Inline-Sequenzen benutzt werden, ohne dass
  175.  * der restliche Code geaendert werden muss.
  176.  *)
  177. BEGIN
  178.  SETREG(8, src); (* a0 -> src *)
  179.  SETREG(9, dst); (* a1 -> dst *)
  180.  SETREG(0, len); (* d0 := len *)
  181. (*
  182. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  183. /* keine Register retten */
  184. #elif HM2
  185.   move.w  D2,-(SP)
  186. #else
  187.   movem.l D1/D2/A0/A1,-(SP)
  188. #endif
  189.   tst.l   D0             ; len = 0 ?
  190.   beq     ende           ; B: ja, nix zu tun
  191.   cmpa.l  A0,A1          ; Zieladresse groesser als Quelladresse ?
  192.   bhi     special        ; B: ja, muss von hinten nach vorne kopiert werden
  193. *                        ; falls sich die Bereiche ueberschneiden
  194.   move.w  A0,D1          ; genau eine Adresse ungerade ?
  195.   move.w  A1,D2          ;
  196.   eor.b   D2,D1          ;
  197.   btst    #0,D1          ;
  198.   beq.s   nfastcpy       ; B: nein, beide gerade/ungerade -> schnell kopieren
  199.  
  200. * Es muss langsam byteweise kopiert werden.
  201. * Der Trick mit dem Sprung in die Kopieranweisungen stammt aus
  202. * dem "bcopy()" der GnuLib/MiNTLib
  203.  
  204.   move.w  D0,D1          ; die Anzahl Bytes im letzten unvollstaendigen 8-er-
  205.   neg.w   D1             ; Block und entsprechenden Index in die
  206.   andi.w  #7,D1          ; Kopieranweisungen berechnen
  207.   add.w   D1,D1          ;
  208.   addq.l  #7,D0          ; plus 1 Block, falls unvollst. Block
  209.   lsr.l   #3,D0          ; Anzahl kompletter 8-er Bloecke [+ unvollst. Block]
  210.   jmp     nloop8(PC,D1.w) ; ersten vollst. oder unvollst. Block kopieren
  211. nloop8:                  ; jeweils 8 Byte kopieren
  212.   move.b  (A0)+,(A1)+
  213.   move.b  (A0)+,(A1)+
  214.   move.b  (A0)+,(A1)+
  215.   move.b  (A0)+,(A1)+
  216.   move.b  (A0)+,(A1)+
  217.   move.b  (A0)+,(A1)+
  218.   move.b  (A0)+,(A1)+
  219.   move.b  (A0)+,(A1)+
  220.   subq.l  #1,D0
  221.   bne.s   nloop8
  222.   bra     ende
  223.  
  224. nfastcpy:
  225.   btst    #0,D2          ; beide Adressen ungerade ?
  226.   beq.s   neven          ; B: nein
  227.   move.b  (A0)+,(A1)+    ; ein Byte vorneweg -> gerade Adressen
  228.   subq.l  #1,D0          ; ein Byte weniger zu kopieren
  229. neven:
  230.   move.b  D0,D2          ; fuer spaeteren Ueberhangtest
  231.   lsr.l   #2,D0          ; Anzahl zu kopierender Langworte
  232.   beq.s   ntstw          ; B: weniger als 4 Byte
  233.   move.w  D0,D1          ; die Anzahl Bytes im letzten unvollstaendigen 32-er-
  234.   neg.w   D1             ; Block und entsprechenden Index in die
  235.   andi.w  #7,D1          ; Kopieranweisungen berechnen
  236.   add.w   D1,D1          ;
  237.   addq.l  #7,D0          ; plus 1 Block, falls unvollst. Block
  238.   lsr.l   #3,D0          ; Anzahl von 32-er-Bloecken [+ unvollst Block]
  239.   jmp     nloop32(PC,D1.w) ; ersten vollst. oder unvollst. Block kopieren
  240. nloop32:                 ; jeweils 32 Byte kopieren
  241.   move.l  (A0)+,(A1)+
  242.   move.l  (A0)+,(A1)+
  243.   move.l  (A0)+,(A1)+
  244.   move.l  (A0)+,(A1)+
  245.   move.l  (A0)+,(A1)+
  246.   move.l  (A0)+,(A1)+
  247.   move.l  (A0)+,(A1)+
  248.   move.l  (A0)+,(A1)+
  249.   subq.l  #1,D0
  250.   bne.s   nloop32
  251. ntstw:
  252.   btst    #1,D2          ; ein zusaetzliches Wort ?
  253.   beq.s   ntstb          ; B: nein
  254.   move.w  (A0)+,(A1)+
  255. ntstb:
  256.   btst    #0,D2          ; ein zusaetzliches Byte ?
  257.   beq     ende           ; B: nein, fertig
  258.   move.b  (A0)+,(A1)+
  259.   bra.s   ende
  260.  
  261. * wie oben, nur alles von hinten nach vorne kopieren
  262.  
  263. special:
  264.   adda.l  D0,A0
  265.   adda.l  D0,A1
  266.  
  267.   move.w  A0,D1
  268.   move.w  A1,D2
  269.   eor.b   D2,D1
  270.   btst    #0,D1
  271.   beq.s   sfastcpy
  272.  
  273.   move.w  D0,D1
  274.   neg.w   D1
  275.   andi.w  #7,D1
  276.   add.w   D1,D1
  277.   addq.l  #7,D0
  278.   lsr.l   #3,D0
  279.   jmp     sloop8(PC,D1.w)
  280. sloop8:
  281.   move.b  -(A0),-(A1)
  282.   move.b  -(A0),-(A1)
  283.   move.b  -(A0),-(A1)
  284.   move.b  -(A0),-(A1)
  285.   move.b  -(A0),-(A1)
  286.   move.b  -(A0),-(A1)
  287.   move.b  -(A0),-(A1)
  288.   move.b  -(A0),-(A1)
  289.   subq.l  #1,D0
  290.   bne.s   sloop8
  291.   bra.s   ende
  292.  
  293. sfastcpy:
  294.   btst    #0,D2
  295.   beq.s   seven
  296.   move.b  -(A0),-(A1)
  297.   subq.l  #1,D0
  298. seven:
  299.   move.b  D0,D2
  300.   lsr.l   #2,D0
  301.   beq.s   ststw
  302.   move.w  D0,D1
  303.   neg.w   D1
  304.   andi.w  #7,D1
  305.   add.w   D1,D1
  306.   addq.l  #7,D0
  307.   lsr.l   #3,D0
  308.   jmp     sloop32(PC,D1.w)
  309. sloop32:
  310.   move.l  -(A0),-(A1)
  311.   move.l  -(A0),-(A1)
  312.   move.l  -(A0),-(A1)
  313.   move.l  -(A0),-(A1)
  314.   move.l  -(A0),-(A1)
  315.   move.l  -(A0),-(A1)
  316.   move.l  -(A0),-(A1)
  317.   move.l  -(A0),-(A1)
  318.   subq.l  #1,D0
  319.   bne.s   sloop32
  320. ststw:
  321.   btst    #1,D2
  322.   beq.s   ststb
  323.   move.w  -(A0),-(A1)
  324. ststb:
  325.   btst    #0,D2
  326.   beq.s   ende
  327.   move.b  -(A0),-(A1)
  328.  
  329. ende:
  330. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  331. /* keine Register retten */
  332. #elif HM2
  333.   move.w  (SP)+,D2
  334. #else
  335.   movem.l (SP)+,D1/D2/A0/A1
  336. #endif
  337.  
  338. *)
  339. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  340. /* */
  341. #elif HM2
  342.  CODE(3F02H);
  343. #else
  344.  CODE(48E7H,40C0H);
  345. #endif
  346.  CODE(4A80H,6700H,0106H,0B3C8H,6200H,0082H,3208H);
  347.  CODE(3409H,0B501H,0801H,0000H,672AH,3200H,4441H,0241H);
  348.  CODE(0007H,0D241H,5E80H,0E688H,4EFBH,1002H,12D8H,12D8H);
  349.  CODE(12D8H,12D8H,12D8H,12D8H,12D8H,12D8H,5380H,66ECH);
  350.  CODE(6000H,00CAH,0802H,0000H,6704H,12D8H,5380H,1400H);
  351.  CODE(0E488H,6726H,3200H,4441H,0241H,0007H,0D241H,5E80H);
  352.  CODE(0E688H,4EFBH,1002H,22D8H,22D8H,22D8H,22D8H,22D8H);
  353.  CODE(22D8H,22D8H,22D8H,5380H,66ECH,0802H,0001H,6702H);
  354.  CODE(32D8H,0802H,0000H,6700H,0084H,12D8H,607EH,0D1C0H);
  355.  CODE(0D3C0H,3208H,3409H,0B501H,0801H,0000H,6728H,3200H);
  356.  CODE(4441H,0241H,0007H,0D241H,5E80H,0E688H,4EFBH,1002H);
  357.  CODE(1320H,1320H,1320H,1320H,1320H,1320H,1320H,1320H);
  358.  CODE(5380H,66ECH,6046H,0802H,0000H,6704H,1320H,5380H);
  359.  CODE(1400H,0E488H,6726H,3200H,4441H,0241H,0007H,0D241H);
  360.  CODE(5E80H,0E688H,4EFBH,1002H,2320H,2320H,2320H,2320H);
  361.  CODE(2320H,2320H,2320H,2320H,5380H,66ECH,0802H,0001H);
  362.  CODE(6702H,3320H,0802H,0000H,6702H,1320H);
  363. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  364. /* */
  365. #elif HM2
  366.  CODE(341FH);
  367. #else
  368.  CODE(4CDFH,0302H);
  369. #endif
  370. END bcopy;
  371.  
  372. (*---------------------------------------------------------------------------*)
  373.  
  374. PROCEDURE bzero ((* EIN/ -- *) dst : ADDRESS;
  375.                  (* EIN/ -- *) len : UNSIGNEDLONG );
  376. (*T*)
  377. (* Die Prozedur veraendert nur die Register D0/D1 und A0/A1.
  378.  * Dies sollte fuer die gaengigen M2-Compiler ausreichen. Falls
  379.  * weitere Register gerettet werden muessen, koennen die
  380.  * einkommentierten Inline-Sequenzen benutzt werden, ohne dass
  381.  * der restliche Code geaendert werden muss.
  382.  *)
  383. BEGIN
  384.  SETREG(8, dst); (* a0 -> dst *)
  385.  SETREG(0, len); (* d0 := len *)
  386. (*
  387. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  388. /* keine Register retten */
  389. #elif HM2
  390.   move.w  D2,-(SP)
  391. #else
  392.   movem.l D1/D2/A0/A1,-(SP)
  393. #endif
  394.   tst.l   D0             ; len = 0 ?
  395.   beq.s   ende           ; B: ja, nix zu tun
  396.  
  397.   moveq   #0,D1          ; wird zum Loeschen benoetigt
  398.   move.w  A0,D2          ; Anfangsadresse ungerade ?
  399.   btst    #0,D2          ;
  400.   beq.s   even           ; B: nein
  401.   move.b  D1,(A0)+       ; sonst ein Byte vorneweg kopieren
  402.   subq.l  #1,D0
  403. even:
  404.   movea.w D0,A1          ; Anzahl der Bytes fuer spaeteren Ueberhangtest merken
  405.   lsr.l   #2,D0          ; Anzahl von Langworten
  406.   beq.s   tstw           ; B: weniger als 4 Byte zu kopieren
  407.   move.w  D0,D2          ; die Anzahl Bytes im letzten unvollstaendigen 32-er-
  408.   neg.w   D2             ; Block und entsprechenden Index in die
  409.   andi.w  #7,D2          ; Kopieranweisungen berechnen
  410.   add.w   D2,D2
  411.   addq.l  #7,D0          ; plus 1 Block, falls unvollst. Block (< 32 Byte)
  412.   lsr.l   #3,D0          ; Anzahl kompletter 32-Byte-Bloecke [+ unvollst. Block]
  413.   jmp     loop32(PC,D2.w) ; ersten kompletten oder unvollst. Block loeschen
  414. loop32:                  ; jeweils 32 Byte loeschen
  415.   move.l  D1,(A0)+
  416.   move.l  D1,(A0)+
  417.   move.l  D1,(A0)+
  418.   move.l  D1,(A0)+
  419.   move.l  D1,(A0)+
  420.   move.l  D1,(A0)+
  421.   move.l  D1,(A0)+
  422.   move.l  D1,(A0)+
  423.   subq.l  #1,D0
  424.   bne.s   loop32         ; naechsten kompletten Block loeschen
  425. tstw:
  426.   move.w  A1,D2
  427.   btst    #1,D2          ; ein zusaetzliches Wort ?
  428.   beq.s   tstb           ; B: nein
  429.   move.w  D1,(A0)+
  430. tstb:
  431.   btst    #0,D2          ; ein zusaetzliches Byte ?
  432.   beq.s   ende           ; B: nein
  433.   move.b  D1,(A0)+
  434. ende:
  435. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  436. /* keine Register retten */
  437. #elif HM2
  438.   move.w  (SP)+,D2
  439. #else
  440.   movem.l (SP)+,D1/D2/A0/A1
  441. #endif
  442. *)
  443. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  444. /* */
  445. #elif HM2
  446.  CODE(3F02H);
  447. #else
  448.  CODE(48E7H,40C0H);
  449. #endif
  450.  CODE(4A80H,674CH,7200H,3408H,0802H,0000H,6704H);
  451.  CODE(10C1H,5380H,3240H,0E488H,6726H,3400H,4442H,0242H);
  452.  CODE(0007H,0D442H,5E80H,0E688H,4EFBH,2002H,20C1H,20C1H);
  453.  CODE(20C1H,20C1H,20C1H,20C1H,20C1H,20C1H,5380H,66ECH);
  454.  CODE(3409H,0802H,0001H,6702H,30C1H,0802H,0000H,6702H);
  455.  CODE(10C1H);
  456. #if LPRM2 || SPCM2 || TDIM2 || MM2 || FTLM2
  457. /* */
  458. #elif HM2
  459.  CODE(341FH);
  460. #else
  461.  CODE(4CDFH,0302H);
  462. #endif
  463. END bzero;
  464.  
  465. (*---------------------------------------------------------------------------*)
  466.  
  467. PROCEDURE lfind ((* EIN/ -- *) key     : ADDRESS;
  468.                  (* EIN/ -- *) base    : ADDRESS;
  469.                  (* EIN/ -- *) nelems  : UNSIGNEDLONG;
  470.                  (* EIN/ -- *) size    : UNSIGNEDLONG;
  471.                  (* EIN/ -- *) compare : CompareProc  ): ADDRESS;
  472. (*T*)
  473. VAR last : ADDRESS;
  474.  
  475. BEGIN
  476.  IF (key = NULL) OR (base = NULL) OR (size = LC(0)) OR (nelems = LC(0)) THEN
  477.    RETURN(NULL);
  478.  END;
  479.  
  480.  last := ADDADR(base, (nelems - LC(1)) * size);
  481.  
  482.  (* Indem das letzte zu vergleichende Feldelement
  483.   * mit dem zu suchenden ausgetauscht wird, wirkt
  484.   * es als Endemarke fuer das Suchen.
  485.   *)
  486.  bswap(key, last, size);
  487.  
  488.  WHILE compare(base, last) <> 0  DO
  489.    base := ADDADR(base, size);
  490.  END;
  491.  
  492.  (* Das Vertauschen muss natuerlich wieder rueckgaengig gemacht werden. *)
  493.  bswap(key, last, size);
  494.  
  495.  (* Wenn das gesamte Feld durchsucht wurde, muss noch
  496.   * der Vergleich mit dem letzten Element erfolgen,
  497.   * ansonsten wurde schon vorher ein Element mit dem
  498.   * gesuchten Wert gefunden.
  499.   *)
  500.  IF (base = last) AND (compare(last, key) <> 0) THEN
  501.    RETURN(NULL);
  502.  ELSE
  503.    RETURN(base);
  504.  END;
  505. END lfind;
  506.  
  507. (*---------------------------------------------------------------------------*)
  508.  
  509. PROCEDURE bsearch ((* EIN/ -- *) key     : ADDRESS;
  510.                    (* EIN/ -- *) base    : ADDRESS;
  511.                    (* EIN/ -- *) nelems  : UNSIGNEDLONG;
  512.                    (* EIN/ -- *) size    : UNSIGNEDLONG;
  513.                    (* EIN/ -- *) compare : CompareProc  ): ADDRESS;
  514. (*T*)
  515. VAR left  : UNSIGNEDLONG;
  516.     right : UNSIGNEDLONG;
  517.     mid   : UNSIGNEDLONG;
  518.  
  519. BEGIN
  520.  IF (key = NULL) OR (base = NULL) OR (size = LC(0)) OR (nelems = LC(0)) THEN
  521.    RETURN(NULL);
  522.  END;
  523.  
  524.  left  := 0;
  525.  right := nelems - LC(1);
  526.  
  527.  WHILE left < right DO
  528.    mid := (left + right) DIV LC(2);
  529.    (* left <= mid < right *)
  530.    IF compare(ADDADR(base, mid * size), key) < 0 THEN
  531.      left  := mid + LC(1);
  532.    ELSE
  533.      right := mid;
  534.    END;
  535.  END;
  536.  
  537.  base := ADDADR(base, left * size);
  538.  IF compare(base, key) = 0 THEN
  539.    RETURN(base);
  540.  ELSE
  541.    RETURN(NULL);
  542.  END;
  543. END bsearch;
  544.  
  545. (*---------------------------------------------------------------------------*)
  546.  
  547. PROCEDURE qsort ((* EIN/ -- *) base    : ADDRESS;
  548.                  (* EIN/ -- *) nelems  : UNSIGNEDLONG;
  549.                  (* EIN/ -- *) size    : UNSIGNEDLONG;
  550.                  (* EIN/ -- *) compare : CompareProc  );
  551. (*T*)
  552. CONST direct = LC(8);
  553.  
  554. VAR cmpP : ADDRESS;
  555.  
  556. VAR rP : ADDRESS;
  557.     (* wird bei Selectionsort benutzt, und ist hier deklariert,
  558.      * damit er keinen Stackplatz beim rekursiven Aufruf von "sort()"
  559.      * belegt. Er braucht keine lokale Variable von "sort()" zu sein,
  560.      * da er nur vom Selectionsort benutzt werden, aus dem heraus kein
  561.      * weiterer rekursiver Aufruf mehr stattfindet.
  562.      *)
  563.  
  564. (* Das Prinzip von Quicksort ist an sich recht einfach:
  565.  
  566.    Als erstes wird ein beliebiges Element des Feldes ausgewaehlt, dann
  567.    werden von beiden Enden des Feldes zur Mitte hin Elemente gesucht, die
  568.    groesser bzw. kleiner oder gleich dem Vergleichselement sind - diese
  569.    beiden Elemente werden ausgetauscht; das Austauschen wird solange
  570.    wiederholt, bis sich die beiden Suchzeiger ueberschneiden; In der linken
  571.    Haelfte befinden sich dann die Elemente, die kleiner oder gleich dem
  572.    Vergleichselement sind, in der rechten Haelfte befinden sich die Elemente,
  573.    die groesser oder gleich dem Vergleichselement sind.
  574.    Diese Prozedur wird jetzt mit den beiden Haelften erneut ausgefuehrt
  575.    usw. bis die zu sortierenden Teilfelder nur noch ein Element gross sind,
  576.    dann ist das gesamte Feld sortiert. Die wiederholte Ausfuehrung gleicher
  577.    Taetigkeiten schreit natuerlich nach Rekursion.
  578.  
  579.    Der Aufwand:
  580.  
  581.    Den Partitionierungsvorgang kann man sich als das Suchen eines bestimmten
  582.    Elementes, naemlich das mit dem naechstgroesseren Wert, vorstellen.
  583.    Angenommen, das Vergleichselement ist immer das wertemaessig mittlere
  584.    Element: in diesem Fall wird die Suche zur Binaersuche, da immer die
  585.    Haelfte der Werte beim naechsten Suchvorgang ausgeschlossen wird. Der
  586.    Aufwand des binaeren Suchens betraegt  O( ld( n )); da wir n Elemente
  587.    haben, betraegt der Sortieraufwand O( n * ld( n )).
  588.    Das waere der Idealfall.
  589.  
  590.    Im schlechtesten Fall ist das ausgewaehlte Vergleichselement immer das
  591.    wertemaessig groesste bzw. kleinste; in diesem Fall wird die Suche zur
  592.    linearen Suche, deren mittlerer Aufwand  n/2 betraegt; der Aufwand des
  593.    Sortierens betraegt dann  O( n * n ). Ein Beispiel waere ein bereits
  594.    sortiertes Feld, bei dem man als Vergleichselement immer das erste
  595.    auswaehlt.
  596.  
  597.    Den schlechtesten Fall kann man zwar nicht ganz ausschliessen, aber
  598.    doch sehr unwahrscheinlich machen: die einfachste Methode ist, als
  599.    Vergleichselement das positionsmaessig mittlere zu nehmen; die
  600.    Wahrscheinlichkeit hierbei haeufig die Extremwerte zu erwischen ist
  601.    gering. Noch unwahrscheinlicher wird es, wenn als Vergleichselement das
  602.    wertemaessig mittlere aus dreien genommen wird (z.B. dem positionsmaessig
  603.    ersten, mittleren und letzten).
  604.  
  605.    Abgesehen von der Wahl des Vergleichselementes gibt es weitere
  606.    Moeglichkeiten zur Optimierung:
  607.  
  608.     - Zuerst die kleinere Haelfte weitersortieren.
  609.       Hierdurch betraegt die Stackbelastung nur  ~ld(n).
  610.  
  611.     - Hinter dem rekursiven Aufruf zur Sortierung der zweiten, groesseren
  612.       Haelfte folgt kein Ausdruck, der vom Ergebnis dieses Aufrufs abhaengt;
  613.       die Sortierung der groesseren Feldes kann deswegen iterativ geschehen.
  614.  
  615.     - Wie alle hoeheren Sortiermethoden ist auch bei Quicksort die Leistung
  616.       bei kleinem  n  schwach, da der Verwaltungsaufwand relativ gross ist.
  617.       Unterschreitet daher die Groesse des zu sortierenden Teilfeldes ein
  618.       hinreichend kleines  n, kann das Feld durch eine einfachere Methode
  619.       (direktes Einfuegen, direkte Auswahl...) zuende sortiert werden.
  620. *)
  621.  
  622. PROCEDURE sort ((* EIN/ -- *) bot : UNSIGNEDLONG;
  623.                 (* EIN/ -- *) top : UNSIGNEDLONG );
  624.  
  625. VAR left   : UNSIGNEDLONG;
  626.     right  : UNSIGNEDLONG;
  627.     leftP  : ADDRESS;
  628.     rightP : ADDRESS;
  629.  
  630. BEGIN (* sort *)
  631.  WHILE bot < top DO
  632.    left   := bot;
  633.    right  := top;
  634.    leftP  := ADDADR(base, bot * size);
  635.    rightP := ADDADR(base, top * size);
  636.  
  637.    IF top - bot < direct THEN
  638.      (* Direktes Sortieren durch Auswaehlen.
  639.       * 'SelectionSort' ist bei so wenigen Elementen
  640.       * (< 10) schneller als 'InsertionSort'.
  641.       *
  642.       * Funktionsweise:
  643.       * Der Reihe nach vom ersten bis zum vorletzten
  644.       * Element wird ein Vergleichselement gewaehlt,
  645.       * das mit allen Elementen rechts von ihm verglichen
  646.       * wird; das Minimum und das Vergleichselement
  647.       * werden ausgetauscht.
  648.       *)
  649.  
  650.      WHILE DIFADR(leftP, rightP) < LIC(0) DO
  651.        cmpP := leftP;
  652.        rP   := ADDADR(leftP, size);
  653.        WHILE DIFADR(rP, rightP) <= LIC(0) DO
  654.          IF compare(rP, cmpP) < 0 THEN
  655.            cmpP := rP;
  656.          END;
  657.          rP := ADDADR(rP, size);
  658.        END; (* WHILE *)
  659.  
  660.        IF cmpP <> leftP THEN
  661.          bswap(cmpP, leftP, size);
  662.        END;
  663.        leftP := ADDADR(leftP, size);
  664.      END;
  665.      RETURN; (* fertig *)
  666.  
  667.    ELSE
  668.  
  669.      (* Es wird kein groesserer Aufwand bei der Auswahl des
  670.       * mittleren Elementes betrieben, da dies in den allermeisten
  671.       * Faellen mehr Zeit kostet, als es Zeit einspart, wenn das
  672.       * Feld wirklich so unguenstig belegt ist, dass das
  673.       * positionsmaessig mittlere immer das Extremelement ist.
  674.       *)
  675.  
  676.      cmpP := ADDADR(base, ((left + right) DIV LC(2)) * size);
  677.  
  678.      REPEAT
  679.  
  680.        (* Bei der Suche nach den auszutauschenden Elementen gibt es
  681.         * zwei Moeglichkeiten:
  682.         *
  683.         *  - Vom jeweiligen Rand ausgehend wird ein Element gesucht,
  684.         *    dass groesser/kleiner ODER GLEICH dem Vergleichselement
  685.         *    ist. Durch die Gleichbedingung wirkt das Vergleichselement
  686.         *    als Endemarke der Iteration, da auf jeden Fall dieses
  687.         *    Element gefunden wird.
  688.         *    Der Nachteil: Kommt der Wert des Vergleichselementes
  689.         *    haufig in dem Feld vor, so finden entsprechend viele
  690.         *    unnoetige Austauschoperationen statt.
  691.         *
  692.         *  - Vom jeweiligen Rand her wird ein Element gesucht, dass
  693.         *    ECHT groesser (kleiner) als das Vergleichselement ist.
  694.         *    Das vermeidet die unnoetigen Austauschoperationen bei
  695.         *    Elementen, die gleich dem Vergleichselement sind;
  696.         *    allerdings wirkt das Vergleichselement nun nicht mehr
  697.         *    als Marke (es kann sein, dass kein Element gefunden
  698.         *    wird, das echt groesser/kleiner als das Vergleichselement
  699.         *    ist), sodass zusaetzlich der Laufindex als Endebedingung
  700.         *    abgefragt werden muss.
  701.         *
  702.         * Es wird die erste Methode benutzt, da eine grosse Anzahl
  703.         * von Elementen mit gleichem Schluessel sicher selten vorkommt,
  704.         * und bei der zweiten Methode dafuer an anderer Stelle mehr
  705.         * Aufwand getrieben werden muss.
  706.         *)
  707.  
  708.        WHILE compare(leftP, cmpP) < 0 DO
  709.          leftP := ADDADR(leftP, size);
  710.          INC(left);
  711.        END;
  712.  
  713.        WHILE compare(cmpP, rightP) < 0 DO
  714.          rightP := SUBADR(rightP, size);
  715.          DEC(right);
  716.        END;
  717.  
  718.        IF left <= right THEN
  719.          bswap(leftP, rightP, size);
  720.          (* Falls das Vergleichselement beim Austausch beteiligt war,
  721.           * muss auch der Zeiger auf das Vergleichselement entsprechend
  722.           * neu gesetzt werden.
  723.           *)
  724.          IF cmpP = leftP THEN
  725.            cmpP := rightP;
  726.          ELSIF cmpP = rightP THEN
  727.            cmpP := leftP;
  728.          END;
  729.  
  730.          IF left < top THEN
  731.            INC(left);
  732.            leftP := ADDADR(leftP, size);
  733.          END;
  734.          IF right > bot THEN
  735.            DEC(right);
  736.            rightP := SUBADR(rightP, size);
  737.          END;
  738.        END;
  739.      UNTIL left > right;
  740.  
  741.      (* (bot<=i<left)->(x[i]<=x[cmpP]) & (right<i<=top)->(x[i]>=x[cmpP]) *)
  742.  
  743.      IF (right - bot) < (top - left) THEN
  744.        (* Nur das kleinere Teilfeld wird rekursiv
  745.         * weitersortiert, das groessere wird durch
  746.         * die darauffolgenden Zuweisungen in der
  747.         * Schleife weiter zerlegt.
  748.         *)
  749.        IF bot < right THEN
  750.          (* Rekursionsbasis: Teilfeld ist sortiert,
  751.           * wenn es nur noch ein Element enthaelt.
  752.           *)
  753.          sort(bot, right);
  754.        END;
  755.        (* Die Elemente left von <left> sind jetzt sortiert,
  756.         * die groessere Haelfte wird in der Schleife
  757.         * weiterbearbeitet.
  758.         *)
  759.        bot := left;
  760.      ELSE
  761.        IF left < top THEN
  762.          sort(left, top);
  763.        END;
  764.        top := right;
  765.      END; (* IF (right ..*)
  766.  
  767.    END; (* IF (top ..*)
  768.  END; (* WHILE *)
  769. END sort;
  770.  
  771. BEGIN (* qsort *)
  772.  IF (base = NULL) OR (size = LC(0)) OR (nelems <= LC(1)) THEN
  773.    RETURN;
  774.  END;
  775.  sort(LC(0), nelems - LC(1));
  776. END qsort;
  777.  
  778. (*---------------------------------------------------------------------------*)
  779.  
  780. PROCEDURE ValToStr ((* EIN/ -- *)     val    : UNSIGNEDLONG;
  781.                     (* EIN/ -- *)     signed : BOOLEAN;
  782.                     (* EIN/ -- *)     base   : CARDINAL;
  783.                     (* -- /AUS *) VAR str    : ARRAY OF CHAR );
  784. (*T*)
  785. VAR basis  : UNSIGNEDLONG;
  786.     len, i : CARDINAL;
  787.     sign   : BOOLEAN;
  788.     digits : ARRAY [0..33] OF CHAR;
  789.  
  790. BEGIN
  791.  IF (base < 2) OR (base > 36) THEN
  792.    basis := 10;
  793.  ELSE
  794.    basis := VAL(UNSIGNEDLONG,base);
  795.  END;
  796.  
  797.  sign := signed AND (base = 10) AND (CAST(SIGNEDLONG,val) < LIC(0));
  798.  IF sign THEN
  799.    IF val <> MINLINT THEN
  800.      (* Abfrage verhindert Ueberlauffehler, da MINLINT im
  801.       * Zweierkomplement nicht als positive Zahl darstellbar ist
  802.       * und unveraendert bleibt.
  803.       *)
  804.      val := CAST(UNSIGNEDLONG,-CAST(SIGNEDLONG,val));
  805.    END;
  806.  END;
  807.  
  808.  (* Die Zahl von hinten nach vorne in String wandeln;
  809.   * durch die REPEAT-Schleife wird auch die Null
  810.   * dargestellt.
  811.   *)
  812.  len := 0;
  813.  REPEAT
  814.    digits[len] := TOUPPER(TODIGIT(VAL(CARDINAL,val MOD basis)));
  815.    val    := val DIV basis;
  816.    INC(len);
  817.  UNTIL val = LC(0);
  818.  IF sign THEN
  819.    digits[len] := '-';
  820.    INC(len);
  821.  END;
  822.  
  823.  
  824.  IF len > VAL(CARDINAL,HIGH(str)) THEN
  825.    len := VAL(CARDINAL,HIGH(str)) + 1;
  826.  ELSE
  827.    str[len] := 0C;
  828.  END;
  829.  
  830.  (* Jetzt wird die Zahlendarstellung in umgekehrter
  831.   * Reihenfolge aus dem Hilfsstring in den eigentlichen
  832.   * String uebertragen. Ausserdem werden Prefix und fuehrende
  833.   * Nullen hinzugefuegt.
  834.   *)
  835.  
  836.  i := 0;
  837.  WHILE len > 0 DO
  838.    DEC(len);
  839.    str[i] := digits[len];
  840.    INC(i);
  841.  END;
  842. END ValToStr;
  843.  
  844. (*---------------------------------------------------------------------------*)
  845.  
  846. PROCEDURE ltoa ((* EIN/ -- *)     num  : SIGNEDLONG;
  847.                 (* -- /AUS *) VAR str  : ARRAY OF CHAR;
  848.                 (* EIN/ -- *)     base : CARDINAL      );
  849. (*T*)
  850. BEGIN
  851.  ValToStr(CAST(UNSIGNEDLONG,num), TRUE, base, str);
  852. END ltoa;
  853.  
  854. (*---------------------------------------------------------------------------*)
  855.  
  856. PROCEDURE ultoa ((* EIN/ -- *)     num  : UNSIGNEDLONG;
  857.                  (* -- /AUS *) VAR str  : ARRAY OF CHAR;
  858.                  (* EIN/ -- *)     base : CARDINAL      );
  859. (*T*)
  860. BEGIN
  861.  ValToStr(num, FALSE, base, str);
  862. END ultoa;
  863.  
  864. (*---------------------------------------------------------------------------*)
  865. #if has_REF
  866. PROCEDURE StrToVal ((* EIN/ -- *) REF str     : ARRAY OF CHAR;
  867. #else
  868. PROCEDURE StrToVal ((* EIN/ -- *) VAR str     : ARRAY OF CHAR;
  869. #endif
  870.                     (* EIN/ -- *)     max     : UNSIGNEDLONG;
  871.                     (* EIN/ -- *)     basis   : CARDINAL;
  872.                     (* EIN/ -- *)     signed  : BOOLEAN;
  873.                     (* -- /AUS *) VAR nextIdx : CARDINAL;
  874.                     (* -- /AUS *) VAR val     : UNSIGNEDLONG  );
  875. (*T*)
  876. VAR idx          : CARDINAL;
  877.     neg          : BOOLEAN;
  878.     digit        : CHAR;
  879.     maxDivBase   : UNSIGNEDLONG;
  880.     maxLastDigit : UNSIGNEDLONG;
  881.     num          : UNSIGNEDLONG;
  882.     base         : UNSIGNEDLONG;
  883.  
  884. BEGIN
  885.  val := 0;
  886.  idx := 0;
  887.  neg := FALSE;
  888.  
  889.  (* Fuehrende Leerzeichen tun nichts zur Sache *)
  890.  WHILE (idx <= VAL(CARDINAL,HIGH(str))) AND ISSPACE(str[idx]) DO
  891.    INC(idx);
  892.  END;
  893.  
  894.  (* Moegliches Vorzeichen feststellen, bei negativer Zahl ist der
  895.   * maximale Wert um eins groesser (im Zweierkomplement).
  896.   *)
  897.  IF signed AND (idx <= VAL(CARDINAL,HIGH(str))) THEN
  898.    digit := str[idx];
  899.    neg   := digit = '-';
  900.    IF digit = '+' THEN
  901.      INC(idx);
  902.    ELSIF neg THEN
  903.      (* Negative Zahlen haben einen um eins groesseren
  904.       * Wertebereich als positive Zahlen (die Null ausgenommen).
  905.       *)
  906.      INC(idx);
  907.      INC(max);
  908.    END;
  909.  END;
  910.  
  911.  (* Keine Zahl kann folgen => Fehler *)
  912.  IF idx > VAL(CARDINAL,HIGH(str)) THEN
  913.    nextIdx := idx;
  914.    RETURN;
  915.  END;
  916.  
  917.  IF (basis < 2) OR (basis > 36) THEN
  918.    basis := 0;
  919.  END;
  920.  base  := VAL(UNSIGNEDLONG,basis);
  921.  digit := str[idx];
  922.  
  923.  IF basis = 0 THEN
  924.    (* Die Basis der Zahl soll aus der Zeichenfolge hervorgehen *)
  925.    INC(idx);
  926.    IF digit = '%' THEN
  927.      (* Zahl in Binaerdarstellung *)
  928.      base := 2;
  929.    ELSIF digit = '0' THEN
  930.      (* Zahl in Sedezimal- oder Oktaldarstellung oder einzelne Null *)
  931.      IF (idx <= VAL(CARDINAL,HIGH(str))) AND (TOUPPER(str[idx]) = 'X') THEN
  932.        base := 16;
  933.        INC(idx);
  934.      ELSE
  935.        base := 8;
  936.      END;
  937.    ELSIF digit = '$' THEN
  938.      base := 16;
  939.    ELSE
  940.      base := 10;
  941.      DEC(idx);
  942.    END;
  943.  
  944.  (* Die Basis ist angegeben, zusaetzliche Angabe in Repraesentation
  945.   * ueberlesen (Oktalnull stoert nicht).
  946.   *)
  947.  ELSIF (basis = 2) AND (digit = '%') THEN
  948.    (* Binaerdarstellung *)
  949.    INC(idx);
  950.  ELSIF basis = 16 THEN
  951.    (* Sedezimaldarstellung *)
  952.    IF digit = '$' THEN
  953.      INC(idx);
  954.    ELSIF  (digit = '0')
  955.       AND (idx < VAL(CARDINAL,HIGH(str)))
  956.       AND (TOUPPER(str[idx+1]) = 'X')
  957.    THEN
  958.      INC(idx, 2);
  959.    END;
  960.  END;
  961.  
  962.  maxDivBase   := max DIV base;
  963.  maxLastDigit := max MOD base;
  964.  
  965.  LOOP
  966.    (* Abbrechen, sobald der String zuende ist, oder ein Zeichen gefunden
  967.     * wurde, das keine gueltige Ziffer ist, oder ein Ueberlauf stattfinden
  968.     * wuerde.
  969.     *)
  970.    nextIdx := idx;
  971.    IF idx > VAL(CARDINAL,HIGH(str)) THEN
  972.      EXIT;
  973.    END;
  974.  
  975.    digit := str[idx];
  976.    num   := VAL(UNSIGNEDLONG,TOCARD(digit));
  977.    IF num >= base THEN
  978.      EXIT;
  979.    END;
  980.  
  981.    (* Da <val> mit jedem neuen Digit um eine Stelle erweitert wird,
  982.     * wird fuer die Ueberlaufpruefung der bisherige <val> vor der
  983.     * Erweiterung mit einem Zehntel des Maximalvales verglichen;
  984.     * wuerde nach der Erweiterung verglichen, waere der Ueberlauf
  985.     * ja womoeglich schon passiert, und dabei koennte auch ein
  986.     * UNSIGNEDLONG-Ueberlauf auftreten -- ein Vergleich wuerde dann
  987.     * nur Unsinn produzieren.
  988.     * Ist der bisherige Wert kleiner als ein Zehntel des Maximums,
  989.     * kann kein Ueberlauf auftreten, ist der bisherige Wert gleich
  990.     * dem Maximumszehntel, muss geprueft werden, ob das neue Digit
  991.     * den Wert des letzten Digits des Maximums ueberschreitet.
  992.     *)
  993.    IF    (val < maxDivBase)
  994.       OR (val = maxDivBase) AND (num <= maxLastDigit)
  995.    THEN
  996.      val := val * base + num;
  997.      INC(idx);
  998.    ELSE (* Ueberlauf *)
  999.      errno := ERANGE;
  1000.      IF neg AND (max <> MINLINT) THEN
  1001.        val := CAST(UNSIGNEDLONG,-CAST(SIGNEDLONG,max));
  1002.      ELSE
  1003.        val := max;
  1004.      END;
  1005.      RETURN;
  1006.    END;
  1007.  END; (* LOOP *)
  1008.  
  1009.  IF neg AND (val <> MINLINT) THEN
  1010.    (* Wenn vor der Zahl ein '-' stand und negative Zahlen erlaubt
  1011.     * sind, den bisher positiven Zahlenwert in einen negativen wandeln.
  1012.     * Abfrage auf MINLINT verhindert Ueberlauf.
  1013.     *)
  1014.    val := CAST(UNSIGNEDLONG,-CAST(SIGNEDLONG,val));
  1015.  END;
  1016. END StrToVal;
  1017.  
  1018. (*---------------------------------------------------------------------------*)
  1019.  
  1020. PROCEDURE strtol ((* EIN/ -- *) REF str  : ARRAY OF CHAR;
  1021.                   (* -- /AUS *) VAR end  : CARDINAL;
  1022.                   (* EIN/ -- *)     base : CARDINAL      ): SIGNEDLONG;
  1023. (*T*)
  1024. VAR val : UNSIGNEDLONG;
  1025.  
  1026. BEGIN
  1027.  StrToVal(str, MAXLINT, base, TRUE, end, val);
  1028.  RETURN(CAST(SIGNEDLONG,val));
  1029. END strtol;
  1030.  
  1031. (*---------------------------------------------------------------------------*)
  1032.  
  1033. PROCEDURE strtoul ((* EIN/ -- *) REF str  : ARRAY OF CHAR;
  1034.                    (* -- /AUS *) VAR end  : CARDINAL;
  1035.                    (* EIN/ -- *)     base : CARDINAL      ): UNSIGNEDLONG;
  1036. (*T*)
  1037. VAR val : UNSIGNEDLONG;
  1038.  
  1039. BEGIN
  1040.  StrToVal(str, MAXLCARD, base, FALSE, end, val);
  1041.  RETURN(val);
  1042. END strtoul;
  1043.  
  1044. (*---------------------------------------------------------------------------*)
  1045.  
  1046. PROCEDURE strerror ((* EIN/ -- *)     errnum : INTEGER;
  1047.                     (* -- /AUS *) VAR errstr : ARRAY OF CHAR );
  1048. (*T*)
  1049. VAR text : ARRAY [0..40] OF CHAR;
  1050.  
  1051. BEGIN
  1052.  CASE errnum OF
  1053.    eOK     : text := "OK";
  1054.   |eRROR   : text := "error";
  1055.   |eDRVNR  : text := "device not ready";
  1056.   |eUNCMD  : text := "unknown command";
  1057.   |eCRC    : text := "crc error";
  1058.   |eBADRQ  : text := "bad request";
  1059.   |eSEEK   : text := "seek error";
  1060.   |eMEDIA  : text := "unknown media";
  1061.   |eSECNF  : text := "sector not found";
  1062.   |ePAPER  : text := "out of paper";
  1063.   |eWRITF  : text := "write failure";
  1064.   |eREADF  : text := "read failure";
  1065.   |eGENRL  : text := "general error";
  1066.   |eWRPRO  : text := "write protected";
  1067.   |eCHNG   : text := "media changed";
  1068.   |eUNDEV  : text := "unknown device";
  1069.   |eBADSF  : text := "bad sectors found";
  1070.   |eOTHER  : text := "another disk";
  1071.  
  1072.   |eINSERT : text := "insert media";
  1073.   |eDVNRSP : text := "device not responding";
  1074.  
  1075.   |eINVFN  : text := "invalid function number";
  1076.   |eFILNF  : text := "file not found";
  1077.   |ePTHNF  : text := "path not found";
  1078.   |eNHNDL  : text := "no more handles";
  1079.   |eACCDN  : text := "access denied";
  1080.   |eIHNDL  : text := "invalid handle";
  1081.   |eNSMEM  : text := "out of memory";
  1082.   |eIMBA   : text := "invalid memory block";
  1083.   |eDRIVE  : text := "invalid drive";
  1084.   |eNSAME  : text := "different drives";
  1085.   |eNMFIL  : text := "no more files";
  1086.  
  1087.   |eLOCKED : text := "file locked";
  1088.   |eNSLOCK : text := "invalid lock";
  1089.  
  1090.   |eRANGE  : text := "range error";
  1091.   |eINTRN  : text := "internal error";
  1092.   |ePLFMT  : text := "not executable";
  1093.   |eGSBF   : text := "memory block growth failure";
  1094.  
  1095.   |E2BIG   : text := "argument list too long";
  1096.   |EAGAIN  : text := "try again";
  1097.   |EBUSY   : text := "resource unavailable";
  1098.   |EDEADLK : text := "deadlock would result";
  1099.   |EDOM    : text := "domain error";
  1100.   |EEXIST  : text := "file exists";
  1101.   |EFBIG   : text := "file too large";
  1102.   |EINTR   : text := "interrupted by signal";
  1103.   |EINVAL  : text := "invalid argument";
  1104.   |EISDIR  : text := "is a directory";
  1105.   |EMLINK  : text := "too many links";
  1106.   |ENAMETOOLONG : text := "filename too long";
  1107.   |ENOLCK  : text := "no locks available";
  1108.   |ENOSPC  : text := "no space left on device";
  1109.   |ENOTEMPTY : text := "directory not empty";
  1110.   |ENOTTY  : text := "wrong i/o control op";
  1111.   |EPIPE   : text := "broken pipe";
  1112.   |ERANGE  : text := "result too large";
  1113.   |ESPIPE  : text := "invalid seek";
  1114.   |ELOOP   : text := "too many symbolic links";
  1115.  ELSE
  1116.              text := "unknown error";
  1117.  END;
  1118.  ASSIGN(text, errstr);
  1119. END strerror;
  1120.  
  1121. (*---------------------------------------------------------------------------*)
  1122.  
  1123. PROCEDURE rand ( ): UNSIGNEDLONG;
  1124. (*T*)
  1125. CONST
  1126.   A = LIC(16807);
  1127.   M = LIC(2147483647);
  1128.   Q = LIC(127773);
  1129.   R = LIC(2836);
  1130.  
  1131. BEGIN
  1132.  Seed := A * (Seed MOD Q) - R * (Seed DIV Q);
  1133.  IF Seed < LIC(0) THEN
  1134.    INC(Seed, M);
  1135.  END;
  1136.  RETURN(Seed);
  1137. END rand;
  1138.  
  1139. (*---------------------------------------------------------------------------*)
  1140.  
  1141. PROCEDURE srand ((* EIN/ -- *) seed : UNSIGNEDLONG );
  1142. (*T*)
  1143. BEGIN
  1144.  Seed := CAST(SIGNEDLONG,seed);
  1145. END srand;
  1146.  
  1147. (*---------------------------------------------------------------------------*)
  1148.  
  1149. PROCEDURE fnmatch ((* EIN/ -- *) REF str   : ARRAY OF CHAR;
  1150.                    (* EIN/ -- *) REF pat   : ARRAY OF CHAR;
  1151.                    (* EIN/ -- *)     flags : FNMFlags      ): BOOLEAN;
  1152. (*T*)
  1153. VAR sLen, pLen : CARDINAL;
  1154.     dot        : BOOLEAN;
  1155.     escape     : BOOLEAN;
  1156.     pathname   : BOOLEAN;
  1157.  
  1158. PROCEDURE match (sidx : CARDINAL;
  1159.                  pidx : CARDINAL ): BOOLEAN;
  1160. (*T*)
  1161. VAR inverted : BOOLEAN;
  1162.     pend     : CARDINAL;
  1163.     cmin     : CHAR;
  1164.     cmax     : CHAR;
  1165.     cs       : CHAR;
  1166.  
  1167. BEGIN (* match *)
  1168.  WHILE pidx < pLen DO
  1169.  
  1170.    IF sidx < sLen THEN
  1171.      cs := str[sidx];
  1172.    ELSE
  1173.      cs := EOS;
  1174.    END;
  1175.  
  1176.    CASE pat[pidx] OF
  1177.      '[': IF    (cs = EOS)
  1178.              OR pathname AND (cs = XDIRSEP)
  1179.              OR dot      AND (cs = '.')
  1180.                          AND (   (sidx = 0)
  1181.                               OR pathname AND (str[sidx-1] = XDIRSEP))
  1182.           THEN
  1183.             (* Wenn der String kein Zeichen mehr enthaelt, oder ein
  1184.              * Pfadtrenner nicht ``gematched'' werden darf, oder ein Dateiname
  1185.              * mit fuehrendem Punkt nicht ``gematched'' werden darf (entweder
  1186.              * am Stringanfang oder direkt nach einem Pfadtrenner), schlaegt
  1187.              * der Vergleich fehl.
  1188.              *)
  1189.             RETURN(FALSE);
  1190.           END;
  1191.  
  1192.           INC(pidx);
  1193.           IF (pidx < pLen) AND (pat[pidx] = INVERTCHAR) THEN
  1194.             inverted := TRUE;
  1195.             INC(pidx);
  1196.           ELSE
  1197.             inverted := FALSE;
  1198.           END;
  1199.           pend := pidx;
  1200.  
  1201.           (* Ein ']' an erster Stelle, evtl. hinter einem '!', beendet nicht
  1202.            * die Menge, sondern steht fuer das zu ``matchende'' Zeichen,
  1203.            * hat also keine Spezialbedeutung. Deswegen wird das erste
  1204.            * Zeichen der Menge uebersprungen.
  1205.            * Wenn das Escapezeichen erlaubt ist, bedeutet "...\]..."
  1206.            * nicht das Ende der Menge, sondern steht fuer ein zu
  1207.            * ``matchendes'' ']'.
  1208.            *)
  1209.           REPEAT
  1210.             INC(pend);
  1211.           UNTIL (pend >= pLen) OR     (pat[pend] = ']')
  1212.                                   AND (   NOT escape
  1213.                                        OR (pat[pend-1] <> ESCAPECHAR));
  1214.  
  1215.           IF pend >= pLen THEN
  1216.             (* Syntaxfehler: Menge nicht korrekt abgeschlossen *)
  1217.             RETURN(FALSE);
  1218.           END;
  1219.  
  1220.           (* Durch das Testen auf korrekten Abschluss mit ']' koennen
  1221.            * in der nachfolgenden Schleife einige Tests auf zu grosses
  1222.            * 'pidx' entfallen.
  1223.            *)
  1224.           LOOP
  1225.             IF escape AND (pat[pidx] = ESCAPECHAR) THEN
  1226.               INC(pidx);
  1227.             END;
  1228.  
  1229.             cmin := pat[pidx];
  1230.             cmax := cmin;
  1231.             INC(pidx);
  1232.  
  1233.             IF (pat[pidx] = '-') AND (pidx + 1 < pend) THEN
  1234.               (* Ein Bereich ist nur vorhanden, falls die Obergrenze
  1235.                * nicht ']' ist; in diesem Fall steht '-' fuer ein
  1236.                * Einzelzeichen, und die Klammer beendet die Menge.
  1237.                *)
  1238.               INC(pidx);
  1239.               IF escape AND (pat[pidx] = ESCAPECHAR) THEN
  1240.                 INC(pidx);
  1241.               END;
  1242.               cmax := pat[pidx];
  1243.               INC(pidx);
  1244.             END;
  1245.  
  1246.             IF (cmin <= cs) AND (cs <= cmax) THEN
  1247.               (* --> MATCH *)
  1248.               IF inverted THEN
  1249.                 RETURN(FALSE);
  1250.               ELSE
  1251.                 pidx := pend;
  1252.                 EXIT;
  1253.               END;
  1254.             ELSIF pidx = pend THEN
  1255.               (* --> NO MATCH *)
  1256.               IF inverted THEN
  1257.                 EXIT;
  1258.               ELSE
  1259.                 RETURN(FALSE);
  1260.               END;
  1261.             END; (* IF cmin <= cs ... *)
  1262.           END; (* LOOP *)
  1263.           INC(sidx);
  1264.           INC(pidx);
  1265.  
  1266.     |'*': REPEAT
  1267.             INC(pidx);
  1268.           UNTIL (pidx = pLen) OR (pat[pidx] <> '*');
  1269.           DEC(pidx);
  1270.  
  1271.           (* Mehrere '*' hintereinander sind aequivalent zu einem einzelnen.
  1272.            * Bis zum letzten '*' ueberlesen.
  1273.            *)
  1274.  
  1275.           IF pathname AND (cs = XDIRSEP) THEN
  1276.             (* Wenn '*' auf einen Pfadtrenner trifft, ``matched'' es nur
  1277.              * die leere Zeichenkette, d.h. der Rest des Musters muss
  1278.              * ohne '*' auf den augenblicklichen String passen.
  1279.              *)
  1280.             INC(pidx);
  1281.           ELSIF dot AND (cs = '.')
  1282.                     AND (   (sidx = 0)
  1283.                          OR pathname AND (str[sidx-1] = XDIRSEP))
  1284.           THEN
  1285.             RETURN(FALSE);
  1286.           ELSE
  1287.  
  1288.             (* Das Muster hinter dem '*' wird mit jedem moeglichen Reststring
  1289.              * verglichen. Das muss rekursiv geschehen, da das Restmuster
  1290.              * wiederum '*' enthalten kann (und auch jedesmal wieder auf
  1291.              * '.' und '/' geachtet werden muss).
  1292.              * Es werden soviele Rekursionsebenen aufgebaut, wie der Reststring
  1293.              * noch lang ist. Beim rekursiven Aufstieg wird dann der Vergleich
  1294.              * durchgefuehrt, wobei in jeder Ebene der Reststring mit dem Muster
  1295.              * hinter dem '*' verglichen wird.
  1296.              *
  1297.              * Der ``schlimmste'' Fall, also der mit den meisten rekursiven
  1298.              * Aufrufen, ist ein Muster folgender Art:
  1299.              *
  1300.              *   pat = "*?*?*?*?*?..."
  1301.              *
  1302.              * und ein String mit mindestens soviel Zeichen, wie das Muster
  1303.              * '*' hat.
  1304.              * Die Zahl an Rekursionsaufrufen berechnet sich in diesem Fall aus:
  1305.              *
  1306.              *   rcalls = 2^stars - 1 + (sLen - stars)
  1307.              *
  1308.              * wobei 'stars' die Anzahl der '*' im Muster ist und sich aus
  1309.              *
  1310.              *   stars = pLen DIV 2
  1311.              *
  1312.              * ergibt.
  1313.              * Der Aufwand ist also exponentiell, falls mehrere '*' im Muster
  1314.              * vorkommen!
  1315.              *
  1316.              * Die ``schlimmste'' Rekursionstiefe ist dagegen nicht ganz so
  1317.              * wild, sie entspricht der Stringlaenge:
  1318.              *
  1319.              *   rdepth = sLen
  1320.              *
  1321.              * Beispiel: str = "xxxx" (sLen =4), pat = "*?*?*?*?" (stars=4)
  1322.              *
  1323.              * Graph der Aufrufe; die Waagerechte kennzeichnet die Rekursions-
  1324.              * ebene, die Zahlen bedeuten die Anzahl der Aufrufe auf der
  1325.              * jeweiligen Ebene (haengen von der jeweiligen Laenge des Rest-
  1326.              * strings ab):
  1327.              *
  1328.              *         Ebene 0:  Aufruf durch 'fnmatch()'
  1329.              *                        |
  1330.              *                        V
  1331.              *         Ebene 1:  -----4--------
  1332.              *                      / | \
  1333.              *                     /  |  \
  1334.              *                   -1---2---3----
  1335.              *            .           /  / \
  1336.              *            .          /  /   \
  1337.              *            .      ---1--1-----2-
  1338.              *                              /
  1339.              *                             /
  1340.              *         Ebene 4:  ---------1----
  1341.              *
  1342.              * insgesamt 15 rekursive Aufrufe.
  1343.              *
  1344.              * Die Strings, dargestellt zum Zeitpunkt des rekursiven Aufrufs:
  1345.              *
  1346.              *   pat  = "*?*?*?"  "*?*?"       "*?*?"   "*?*?"
  1347.              *
  1348.              *   str  =   "123"  .............  "23"  ..  "3"
  1349.              *              |                    |         |
  1350.              *             "23"  .. "3"         "3"        ""
  1351.              *              |        |           |
  1352.              *             "3"       ""          ""
  1353.              *              |
  1354.              *              ""
  1355.              *
  1356.              * Falls der String laenger ist, wird die Rekursionsebene erst
  1357.              * solange linear erhoeht, bis der Reststring genauso lang wie die
  1358.              * Anzahl der '*', dann spannt sich der Baum genauso auf.
  1359.              *)
  1360.             IF (cs <> EOS) AND match(sidx+1, pidx) THEN
  1361.               RETURN(TRUE);
  1362.             END;
  1363.             INC(pidx);
  1364.           END;
  1365.  
  1366.     |'?': IF    (cs = EOS)
  1367.              OR pathname AND (cs = XDIRSEP)
  1368.              OR dot      AND (cs = '.')
  1369.                          AND (   (sidx = 0)
  1370.                               OR pathname AND (str[sidx-1] = XDIRSEP))
  1371.           THEN
  1372.             RETURN(FALSE);
  1373.           END;
  1374.           INC(sidx);
  1375.           INC(pidx);
  1376.  
  1377.     |ESCAPECHAR:
  1378.           IF escape THEN
  1379.             INC(pidx);
  1380.           END;
  1381.           IF pidx = pLen THEN
  1382.             RETURN(cs = EOS);
  1383.           ELSIF pat[pidx] <> cs THEN
  1384.             RETURN(FALSE);
  1385.           END;
  1386.           INC(sidx);
  1387.           INC(pidx);
  1388.  
  1389.      ELSE
  1390.           IF pat[pidx] <> cs THEN
  1391.             RETURN(FALSE);
  1392.           END;
  1393.           INC(sidx);
  1394.           INC(pidx);
  1395.    END; (* CASE *)
  1396.  END; (* WHILE *)
  1397.  
  1398.  (* Wenn das Muster beendet ist, muss auch der String zuende sein.*)
  1399.  RETURN(sidx = sLen);
  1400. END match;
  1401.  
  1402. BEGIN (* fnmatch *)
  1403.  escape   := NOT (fnmNOESCAPE IN flags);
  1404.  pathname := fnmPATHNAME IN flags;
  1405.  dot      := fnmPERIOD IN flags;
  1406.  sLen     := SLEN(str);
  1407.  pLen     := SLEN(pat);
  1408.  
  1409.  RETURN(match(0, 0));
  1410. END fnmatch;
  1411.  
  1412. (*===========================================================================*)
  1413.  
  1414. BEGIN (* lib *)
  1415.  Seed := 1;
  1416. END lib.
  1417.