Changeset 35341 in project


Ignore:
Timestamp:
03/25/18 19:50:42 (5 weeks ago)
Author:
kon
Message:

add types, message-digest-result-form -> -type, -form is symbol, -byte-order is symbol, do not type check-/error- (no no no no no)

Location:
release/4/message-digest/trunk
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • release/4/message-digest/trunk/message-digest-bv.scm

    r35340 r35341  
    3737
    3838;;
     39
     40;FIXME do not 'type' check-/error- procs
    3941
    4042(define (check-blob/slice loc blb start end)
     
    8284;; Single Source API
    8385
    84 (define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result-form
     86(define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result-type
    8587  (let-optionals* opts (
    86     (result-type (message-digest-result-form))
     88    (restyp (message-digest-result-form))
    8789    (start 0)
    8890    (end (blob-size blb)) )
     
    9092      (md (initialize-message-digest mdp)) )
    9193      (message-digest-update-blob md blb start end)
    92       (finalize-message-digest md result-type) ) ) )
     94      (finalize-message-digest md restyp) ) ) )
    9395
    94 (define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result-form
     96(define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result-type
    9597  (let-optionals* opts (
    96     (result-type (message-digest-result-form))
     98    (restyp (message-digest-result-form))
    9799    (start 0)
    98100    (end (string-length str)) )
     
    100102      (md (initialize-message-digest mdp)) )
    101103      (message-digest-update-string md str start end)
    102       (finalize-message-digest md result-type) ) ) )
     104      (finalize-message-digest md restyp) ) ) )
    103105
    104 (define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
     106(define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
    105107  (let-optionals* opts (
    106108    (start 0)
     
    111113      (finalize-message-digest! md buf) ) ) )
    112114
    113 (define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
     115(define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
    114116  (let-optionals* opts (
    115117    (start 0)
  • release/4/message-digest/trunk/message-digest-int.scm

    r35339 r35341  
    4444;;
    4545
    46 (define: (get-byte-order (loc symbol) (obj *)) --> symbol
     46(define: (get-byte-order (loc symbol) (obj *)) --> message-digest-byte-order
    4747  (case obj
    4848        ((big-endian be big msb)                                'big-endian )
     
    109109;; Machine Byte Order w/ Char & Unsigned Integer
    110110
    111 (define: (message-digest-update-char (md message-digest) (ch char) . (opts (list-of symbol))) -> void
     111(define: (message-digest-update-char (md message-digest) (ch char) . (opts (list message-digest-byte-order))) -> void
    112112  (let (
    113113    (order (optional opts (machine-byte-order))) )
     
    116116      ((big-endian)                     (message-digest-update-char-be md ch) ) ) ) )
    117117
    118 (define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list-of symbol))) -> void
     118(define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
    119119  (let (
    120120    (order (optional opts (machine-byte-order))) )
     
    123123      ((big-endian)                     (message-digest-update-u16-be md n) ) ) ) )
    124124
    125 (define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list-of symbol))) -> void
     125(define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
    126126  (let (
    127127    (order (optional opts (machine-byte-order))) )
     
    130130      ((big-endian)                     (message-digest-update-u32-be md n) ) ) ) )
    131131
    132 (define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list-of symbol))) -> void
     132(define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
    133133  (let (
    134134    (order (optional opts (machine-byte-order))) )
  • release/4/message-digest/trunk/message-digest-item.scm

    r35339 r35341  
    3535;;
    3636
    37 (define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result-form
     37(define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result-type
    3838  (let-optionals* opts (
    39     (result-type (message-digest-result-form))
     39    (restyp (message-digest-result-form))
    4040    (start 0)
    4141    (end #f) )
    4242    (let ((md (initialize-message-digest mdp)))
    4343      (message-digest-update-object md obj start end)
    44       (finalize-message-digest md result-type) ) ) )
     44      (finalize-message-digest md restyp) ) ) )
    4545
    46 (define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result-form
    47   (let* (
    48     (result-type (message-digest-result-form))
     46(define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result-type
     47  (let (
     48    (restyp (message-digest-result-form))
    4949    (md (initialize-message-digest mdp)) )
    5050    (message-digest-update-file md flnm)
    51     (finalize-message-digest md result-type) ) )
     51    (finalize-message-digest md restyp) ) )
    5252
    53 (define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result-form
    54   (let* (
    55     (result-type (message-digest-result-form))
     53(define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result-type
     54  (let (
     55    (restyp (message-digest-result-form))
    5656    (md (initialize-message-digest mdp)) )
    5757    (message-digest-update-port md port)
    58     (finalize-message-digest md result-type) ) )
     58    (finalize-message-digest md restyp) ) )
    5959
    6060;;
    6161
    62 (define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
     62(define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
    6363  (let-optionals* opts (
    6464    (start 0)
     
    6969      (finalize-message-digest! md buf) ) ) )
    7070
    71 (define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-form
     71(define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-type
    7272  (let (
    7373    (md (initialize-message-digest mdp)) )
     
    7575    (finalize-message-digest! md buf) ) )
    7676
    77 (define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-form
    78   (let ((md (initialize-message-digest mdp)))
     77(define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-type
     78  (let (
     79    (md (initialize-message-digest mdp)) )
    7980    (message-digest-update-port md port)
    8081    (finalize-message-digest! md buf) ) )
  • release/4/message-digest/trunk/message-digest-port.scm

    r35340 r35341  
    3131
    3232(declare
    33   (bound-to-procedure ##sys#slot ##sys#setslot))
     33  (bound-to-procedure
     34    ##sys#slot ##sys#setslot))
    3435
    3536;;; Support
     
    3839
    3940(include "message-digest-types")
     41
     42;;
     43
     44(define PORT-TAG 'digest)
     45
     46(define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive"))
    4047
    4148;;
     
    5360  (##sys#setslot p 3 s) )
    5461
     62;;
     63
    5564(define (check-open-port loc obj #!optional argnam)
    5665  (if (port-closed? obj)
     
    6170  (let (
    6271    (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
    63     (unless (eq? 'digest pt)
     72    (unless (eq? PORT-TAG pt)
    6473      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
    6574  obj )
    6675
    6776;Synthesize a port-name from a primitive-name
    68 (define (make-digest-port-name mdp)
     77(define: (make-digest-port-name (mdp message-digest-primitive)) --> string
    6978  (let* (
    70     (nam (->string (or (message-digest-primitive-name mdp) 'md)))
     79    (nam
     80      (->string (or (message-digest-primitive-name mdp) 'md)))
    7181    ;strip trailing (why ?)
    72     (remlen (string-suffix-length-ci nam "-primitive"))
    73     (remlen (if (fxpositive? remlen) remlen (string-suffix-length-ci nam "p"))) )
    74     (string-append
    75       "("
    76         (if (fxpositive? remlen)
    77           (substring nam 0 (fx- (string-length nam) remlen))
    78           nam )
    79       ")") ) )
     82    (remlen
     83      ;longest suffix length or negative
     84      (foldl
     85        (lambda (remlen suf)
     86          (fxmax remlen (string-suffix-length-ci nam suf)) )
     87        -1
     88        PRIMITIVE-NAME-SUFFIXES))
     89    (nam
     90      (if (fxpositive? remlen)
     91        (substring nam 0 (fx- (string-length nam) remlen))
     92        nam)) )
     93    (string-append "(" nam ")") ) )
    8094
    8195;;; Message Digest Output Port API
    8296
    83 ;; Returns a digest-output-port for the MDP
    84 
    85 (define (open-output-digest mdp)
     97(define: (open-output-digest (mdp message-digest-primitive)) -> digest-output-port
    8698  (let* (
    8799    (md
     
    89101    (writer
    90102      (lambda (obj)
    91         ;it will only ever be a string for now
     103        ;for now only a string
    92104        (if (string? obj)
    93105          (message-digest-update-string md obj)
     
    97109        (make-output-port writer void)) )
    98110    (##sys#set-port-data! port md)
    99     (%port-type-set! port 'digest)
     111    (%port-type-set! port PORT-TAG)
    100112    (%port-name-set! port (make-digest-port-name mdp))
    101113    port ) )
    102114
     115(: digest-output-port? (* -> boolean : digest-output-port))
     116;
    103117(define (digest-output-port? obj)
    104118  (and
    105119    (output-port? obj)
    106     (eq? 'digest (%port-type obj)) ) )
     120    (eq? PORT-TAG (%port-type obj)) ) )
    107121
    108122(define-check+error-type digest-output-port)
    109123
    110 (define (digest-output-port-name p)
    111   (%port-name (check-digest-output-port 'digest-output-port-name p)) )
     124(define: (digest-output-port-name (port digest-output-port)) -> string
     125  (%port-name
     126    (check-digest-output-port 'digest-output-port-name port)) )
    112127
    113 ;; Finalizes the digest-output-port and returns the result in the form requested
    114 
    115 (define (*close-output-digest loc digest-port result-type)
     128(define: (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
    116129  (let (
    117130    (res
    118131      (finalize-message-digest
    119         (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
    120         result-type)) )
    121     (close-output-port digest-port)
     132        (##sys#port-data
     133          (check-open-digest-output-port loc port 'digest-port))
     134        restyp)) )
     135    (close-output-port port)
    122136    res ) )
    123137
    124 (define (get-output-digest digest-port #!optional (result-type (message-digest-result-form)))
    125   (*close-output-digest 'get-output-digest digest-port result-type) )
     138(define: (get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type
     139  (let (
     140    (restyp (optional opts (message-digest-result-form))) )
     141    (*close-output-digest 'get-output-digest port restyp) ) )
    126142
    127143;;;
    128144
    129 ;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP.
    130 ;; Returns the accumulated output string | blob | u8vector | hexstring
    131 
    132 (define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
     145(define: (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
    133146  (let (
     147    (restyp (optional opts (message-digest-result-form)))
    134148    (port (open-output-digest mdp)) )
    135149    (proc port)
    136     (*close-output-digest 'call-with-output-digest port result-type) ) )
     150    (*close-output-digest 'call-with-output-digest port restyp) ) )
    137151
    138 ;; Calls the procedure THUNK with the current-input-port temporarily bound to a
    139 ;; digest-output-port for the MDP.
    140 ;; Returns the accumulated output string | blob | u8vector | hexstring
    141 
    142 (define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form)))
    143   (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
     152(define: (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
     153  (let (
     154    (restyp (optional opts (message-digest-result-form))) )
     155    (call-with-output-digest mdp (cut with-input-from-port <> thunk) restyp) ) )
    144156
    145157) ;module message-digest
  • release/4/message-digest/trunk/message-digest-srfi-4.scm

    r35339 r35341  
    6464;;; Single Source API
    6565
    66 (define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-form
     66(define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-type
    6767  (let-optionals* opts (
    68     (result-type (message-digest-result-form))
     68    (restyp (message-digest-result-form))
    6969    (start 0)
    7070    (end (u8vector-length u8vec)) )
    7171    (let ((md (initialize-message-digest mdp)))
    7272      (message-digest-update-u8vector md u8vec start end)
    73       (finalize-message-digest md result-type) ) ) )
     73      (finalize-message-digest md restyp) ) ) )
    7474
    75 (define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-form
     75(define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-type
    7676  (let-optionals* opts (
    7777    (start 0)
     
    8989(: message-digest-update-packed-vector deprecated)
    9090(define (message-digest-update-packed-vector md pkdvec)
    91   (let ((blb (packed-vector->blob/shared pkdvec)))
     91  (let (
     92    (blb (packed-vector->blob/shared pkdvec)) )
    9293    (if blb
    9394      (message-digest-update-blob md blb)
     
    9798(define (message-digest-update-bytevector md bv #!optional (len (number-of-bytes bv)))
    9899  (check-message-digest 'message-digest-update-bytevector md)
    99   (let ((mdp (message-digest-algorithm md))
    100         (ctx (message-digest-context md)) )
     100  (let (
     101    (mdp (message-digest-algorithm md))
     102    (ctx (message-digest-context md)) )
    101103    ((message-digest-primitive-update mdp)
    102104        ctx
  • release/4/message-digest/trunk/message-digest-type.scm

    r35339 r35341  
    6060;assumes blob 'res' may not be of result size
    6161
    62 (define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
    63   (case (canonical-result-name rt)
     62(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
     63  (case (canonical-result-name restyp)
    6464    ((blob)           res )
    6565    ((byte-string)    (blob->string res) )
     
    6767    ((u8vector)       (blob->u8vector/shared res) )
    6868    (else
    69       (error-result-form loc rt) ) ) )
     69      (error-result-form loc restyp) ) ) )
    7070
    7171#;
    72 (define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
    73   (case rt
     72(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
     73  (case restyp
    7474    ((blob)
    7575      (if (fx= len (blob-size res)) res
     
    8686          (subu8vector vec 0 len) ) ) )
    8787    (else
    88       (error-result-form loc rt) ) ) )
    89 
    90 (define: (canonical-result-name (x symbol)) -> (or boolean symbol)
     88      (error-result-form loc restyp) ) ) )
     89
     90(define: (canonical-result-name (x message-digest-result-form)) -> (or boolean message-digest-result-form)
    9191  (case x
    9292    ((blob)                       'blob )
     
    9797      #f ) ) )
    9898
    99 (define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-form)) -> message-digest-result-form
     99(define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-type)) -> message-digest-result-type
    100100  (let (
    101101    (siz
     
    119119;;
    120120
    121 (: message-digest-result-form (#!optional symbol -> symbol))
     121(: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form))
    122122;
    123123(define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string
     
    162162;;
    163163
    164 (define: (finalize-message-digest (md message-digest) . (opts (list-of message-digest-result-form))) -> message-digest-result-form
     164(define: (finalize-message-digest (md message-digest) . (opts (list message-digest-result-type))) -> message-digest-result-type
    165165  (let* (
    166     (result-type
    167       (optional opts (message-digest-result-form)))
    168     (mdp
    169       (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
    170     (res
    171       (make-blob (message-digest-primitive-digest-length mdp))) )
     166    (restyp (optional opts (message-digest-result-form)))
     167    (mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
     168    (res (make-blob (message-digest-primitive-digest-length mdp))) )
    172169    ;side-effects res
    173170    ((message-digest-primitive-final mdp) (message-digest-context md) res)
    174     (get-result-form 'finalize-message-digest res result-type) ) )
    175 
    176 (define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-form
     171    (get-result-form 'finalize-message-digest res restyp) ) )
     172
     173(define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-type
    177174  (let* (
    178175    (mdp
     
    192189    (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
    193190    ;enough space? then reuse, otherwise new buffer
    194     (if buf (print "buf " buf))
    195191    (if (and buf (fx<= sz (number-of-bytes buf)))
    196192      buf
  • release/4/message-digest/trunk/message-digest-types.scm

    r35339 r35341  
    99(define-type pathname string)
    1010
    11 (define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
     11(define-type srfi4vector
     12  (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
    1213
    13 ;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer))
     14#; ;desired, bufpointer is (pointer + length)
     15(define-type message-digest-buffer
     16  (or string blob srfi4vector procedure input-port bufpointer))
    1417(define-type message-digest-buffer (or string blob u8vector))
    1518
    16 (define-type message-digest-result-form (or string blob u8vector))
     19(define-type message-digest-byte-order symbol)
     20
     21(define-type message-digest-result-form symbol)
     22
     23(define-type message-digest-result-type (or string blob u8vector))
    1724
    1825(define-type message-digest-buffer (or string blob u8vector))
     
    2330
    2431(define-type message-digest (struct message-digest))
     32
     33(define-type digest-output-port output-port)
Note: See TracChangeset for help on using the changeset viewer.