Ignore:
Timestamp:
03/25/18 19:50:42 (2 years ago)
Author:
Kon Lovett
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)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.