home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / misc / bcpl.ark / BLIB.B < prev    next >
Encoding:
Text File  |  1988-11-27  |  3.3 KB  |  125 lines
  1. SECTION "BLIB"
  2.  
  3. GET "LIBHDR"
  4.  
  5. LET WRITED(N,D) BE
  6. $( LET T = VEC 5
  7.    AND I, K = 0, -N
  8.    IF N<0 DO D,K := D-1, N
  9.    T!I, K, I := -(K REM 10), K/10, I+1 REPEATUNTIL K=0
  10.    FOR J = I+1 TO D DO WRCH('*S')
  11.    IF N<0 DO WRCH('-')
  12.    FOR J = I-1 TO 0 BY -1 DO WRCH(T!J + '0' )
  13. $)
  14.  
  15. LET WRITES(X) BE FOR K = 1 TO X%0 DO WRCH(X%K)
  16.  
  17. LET NEWLINE() BE WRCH('*N')
  18.  
  19. LET NEWPAGE() BE WRCH('*P')
  20.  
  21. LET WRITEN(N) BE WRITED(N, 0)
  22.  
  23. LET WRITEOCT(N ,D) BE
  24. $( IF D>1 DO WRITEOCT(N>>3, D-1)
  25.    WRCH((N&7) + '0') 
  26. $)
  27.  
  28. LET WRITEO(N) BE WRITEOCT(N,6)
  29.  
  30. LET WRITEHEX(N, D) BE
  31. $( IF D>1 DO WRITEHEX(N>>4, D-1)
  32.    WRCH("0123456789ABCDEF"%(1+(N&15)))  
  33. $)
  34.  
  35. LET WRITEX(N) BE WRITEHEX(N, 4)
  36.  
  37. LET WRITEU(N, D) BE
  38. $( LET M = (N>>1)/5
  39.    UNLESS M=0 DO
  40.       $( WRITED(M, D-1)
  41.          D := 1
  42.       $)
  43.    WRITED(N-M*10, D)
  44. $)
  45.  
  46. LET WRITET(S, N) BE
  47. $( WRITES(S)
  48.    FOR I = (S%0)+1 TO N DO WRCH('*S')
  49. $)
  50.  
  51. LET WRITEF(FORMAT, A, B, C, D, E, F, G, H, I, J, K) BE WRITEF1(FORMAT, @A)
  52.  
  53. AND WRITEF1(FORMAT, T) = VALOF
  54. $( FOR P = 1 TO FORMAT%0 DO
  55.    $( TEST FORMAT%P ~= '%' THEN WRCH(FORMAT%P)
  56.       ELSE
  57.           $( LET ARG = !T
  58.              LET F, CH, N = ?, ?, 0
  59.              P := P+1
  60.              SWITCHON FORMAT%P INTO
  61.                   $( DEFAULT: WRCH(CH);          LOOP
  62.  
  63.                      CASE 'F': CASE 'f':
  64.                            T := WRITEF1(ARG, T+1)
  65.                                                  LOOP
  66.  
  67.                      CASE 'T': CASE 't':
  68.                            F := WRITET;          GOTO M
  69.                      CASE 'U': CASE 'u':
  70.                            F := WRITEU;          GOTO M
  71.                      CASE 'S': CASE 's':
  72.                            F := WRITES;          GOTO L
  73.                      CASE 'C': CASE 'c':
  74.                            F := WRCH;            GOTO L
  75.                      CASE 'O': CASE 'o':
  76.                            F := WRITEOCT;        GOTO M
  77.                      CASE 'X': CASE 'x':
  78.                            F := WRITEHEX;        GOTO M
  79.                      CASE 'I': CASE 'i':
  80.                            F := WRITED;          GOTO M
  81.                      CASE 'N': CASE 'n':
  82.                            F := WRITED;          GOTO L  
  83.  
  84.                    M: P := P+1
  85.                      CH := FORMAT%P
  86.                       N := '0'<=CH<='9' -> CH - '0',
  87.                            'a'<=CH<='f' -> CH + ( 10 - 'a' ),
  88.                            'A'<=CH<='F' -> CH + ( 10 - 'A' ),0
  89.  
  90.                    L: F(ARG, N)
  91.  
  92.                      CASE '$':
  93.                      T := T+1  
  94.  
  95.                   $)
  96.             $)                
  97.        $)
  98.    RESULTIS T
  99. $)
  100.  
  101.  
  102. LET READN() = VALOF
  103. $( LET SUM = 0
  104.    AND NEG = FALSE
  105.  
  106.    L:TERMINATOR := RDCH()
  107.        SWITCHON TERMINATOR INTO
  108.        $( CASE '*S':
  109.           CASE '*T':
  110.           CASE '*N':   GOTO L
  111.  
  112.           CASE '-' : NEG := TRUE
  113.           CASE '+' : TERMINATOR := RDCH()
  114.        $)
  115.        WHILE '0' <=TERMINATOR<= '9' DO
  116.                      $(   SUM := 10*SUM + TERMINATOR - '0'
  117.                           TERMINATOR := RDCH()
  118.                      $)
  119.        IF NEG THEN SUM := -SUM
  120.        RESULTIS SUM
  121. $)
  122.  
  123. LET RANDOM(N) = 41965*N + 7473
  124.  
  125.