Changeset 35341 in project

Timestamp:

03/25/18 19:50:42 (9 months 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:

• message-digest-bv.scm (modified) (5 diffs)
• message-digest-int.scm (modified) (5 diffs)
• message-digest-item.scm (modified) (3 diffs)
• message-digest-port.scm (modified) (6 diffs)
• message-digest-srfi-4.scm (modified) (3 diffs)
• message-digest-type.scm (modified) (7 diffs)
• message-digest-types.scm (modified) (2 diffs)

release/4/message-digest/trunk/message-digest-bv.scm

@@ -37 +37 @@
 
 ;;
+
+;FIXME do not 'type' check-/error- procs
 
 (define (check-blob/slice loc blb start end)
@@ -82 +84 @@
 ;; Single Source API
 
-(define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result-form
+(define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
-    (result-type (message-digest-result-form))
+    (restyp (message-digest-result-form))
     (start 0)
     (end (blob-size blb)) )
@@ -90 +92 @@
       (md (initialize-message-digest mdp)) )
       (message-digest-update-blob md blb start end)
-      (finalize-message-digest md result-type) ) ) )
+      (finalize-message-digest md restyp) ) ) )
 
-(define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result-form
+(define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
-    (result-type (message-digest-result-form))
+    (restyp (message-digest-result-form))
     (start 0)
     (end (string-length str)) )
@@ -100 +102 @@
       (md (initialize-message-digest mdp)) )
       (message-digest-update-string md str start end)
-      (finalize-message-digest md result-type) ) ) )
+      (finalize-message-digest md restyp) ) ) )
 
-(define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
+(define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
     (start 0)
@@ -111 +113 @@
       (finalize-message-digest! md buf) ) ) )
 
-(define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
+(define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
     (start 0)

release/4/message-digest/trunk/message-digest-int.scm

@@ -44 +44 @@
 ;;
 
-(define: (get-byte-order (loc symbol) (obj *)) --> symbol
+(define: (get-byte-order (loc symbol) (obj *)) --> message-digest-byte-order
   (case obj
         ((big-endian be big msb)                                'big-endian )
@@ -109 +109 @@
 ;; Machine Byte Order w/ Char & Unsigned Integer
 
-(define: (message-digest-update-char (md message-digest) (ch char) . (opts (list-of symbol))) -> void
+(define: (message-digest-update-char (md message-digest) (ch char) . (opts (list message-digest-byte-order))) -> void
   (let (
     (order (optional opts (machine-byte-order))) )
@@ -116 +116 @@
       ((big-endian)                     (message-digest-update-char-be md ch) ) ) ) )
 
-(define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list-of symbol))) -> void
+(define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
   (let (
     (order (optional opts (machine-byte-order))) )
@@ -123 +123 @@
       ((big-endian)                     (message-digest-update-u16-be md n) ) ) ) )
 
-(define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list-of symbol))) -> void
+(define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
   (let (
     (order (optional opts (machine-byte-order))) )
@@ -130 +130 @@
       ((big-endian)                     (message-digest-update-u32-be md n) ) ) ) )
 
-(define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list-of symbol))) -> void
+(define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void
   (let (
     (order (optional opts (machine-byte-order))) )

release/4/message-digest/trunk/message-digest-item.scm

@@ -35 +35 @@
 ;;
 
-(define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result-form
+(define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
-    (result-type (message-digest-result-form))
+    (restyp (message-digest-result-form))
     (start 0)
     (end #f) )
     (let ((md (initialize-message-digest mdp)))
       (message-digest-update-object md obj start end)
-      (finalize-message-digest md result-type) ) ) )
+      (finalize-message-digest md restyp) ) ) )
 
-(define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result-form
-  (let* (
-    (result-type (message-digest-result-form))
+(define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result-type
+  (let (
+    (restyp (message-digest-result-form))
     (md (initialize-message-digest mdp)) )
     (message-digest-update-file md flnm)
-    (finalize-message-digest md result-type) ) )
+    (finalize-message-digest md restyp) ) )
 
-(define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result-form
-  (let* (
-    (result-type (message-digest-result-form))
+(define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result-type
+  (let (
+    (restyp (message-digest-result-form))
     (md (initialize-message-digest mdp)) )
     (message-digest-update-port md port)
-    (finalize-message-digest md result-type) ) )
+    (finalize-message-digest md restyp) ) )
 
 ;;
 
-(define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-form
+(define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
     (start 0)
@@ -69 +69 @@
       (finalize-message-digest! md buf) ) ) )
 
-(define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-form
+(define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-type
   (let (
     (md (initialize-message-digest mdp)) )
@@ -75 +75 @@
     (finalize-message-digest! md buf) ) )
 
-(define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-form
-  (let ((md (initialize-message-digest mdp)))
+(define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-type
+  (let (
+    (md (initialize-message-digest mdp)) )
     (message-digest-update-port md port)
     (finalize-message-digest! md buf) ) )

release/4/message-digest/trunk/message-digest-port.scm

@@ -31 +31 @@
 
 (declare
-  (bound-to-procedure ##sys#slot ##sys#setslot))
+  (bound-to-procedure
+    ##sys#slot ##sys#setslot))
 
 ;;; Support
@@ -38 +39 @@
 
 (include "message-digest-types")
+
+;;
+
+(define PORT-TAG 'digest)
+
+(define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive"))
 
 ;;
@@ -53 +60 @@
   (##sys#setslot p 3 s) )
 
+;;
+
 (define (check-open-port loc obj #!optional argnam)
   (if (port-closed? obj)
@@ -61 +70 @@
   (let (
     (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
-    (unless (eq? 'digest pt)
+    (unless (eq? PORT-TAG pt)
       (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
   obj )
 
 ;Synthesize a port-name from a primitive-name
-(define (make-digest-port-name mdp)
+(define: (make-digest-port-name (mdp message-digest-primitive)) --> string
   (let* (
-    (nam (->string (or (message-digest-primitive-name mdp) 'md)))
+    (nam
+      (->string (or (message-digest-primitive-name mdp) 'md)))
     ;strip trailing (why ?)
-    (remlen (string-suffix-length-ci nam "-primitive"))
-    (remlen (if (fxpositive? remlen) remlen (string-suffix-length-ci nam "p"))) )
-    (string-append
-      "("
-        (if (fxpositive? remlen)
-          (substring nam 0 (fx- (string-length nam) remlen))
-          nam )
-      ")") ) )
+    (remlen
+      ;longest suffix length or negative
+      (foldl
+        (lambda (remlen suf)
+          (fxmax remlen (string-suffix-length-ci nam suf)) )
+        -1
+        PRIMITIVE-NAME-SUFFIXES))
+    (nam
+      (if (fxpositive? remlen)
+        (substring nam 0 (fx- (string-length nam) remlen))
+        nam)) )
+    (string-append "(" nam ")") ) )
 
 ;;; Message Digest Output Port API
 
-;; Returns a digest-output-port for the MDP
-
-(define (open-output-digest mdp)
+(define: (open-output-digest (mdp message-digest-primitive)) -> digest-output-port
   (let* (
     (md
@@ -89 +101 @@
     (writer
       (lambda (obj)
-        ;it will only ever be a string for now
+        ;for now only a string
         (if (string? obj)
           (message-digest-update-string md obj)
@@ -97 +109 @@
         (make-output-port writer void)) )
     (##sys#set-port-data! port md)
-    (%port-type-set! port 'digest)
+    (%port-type-set! port PORT-TAG)
     (%port-name-set! port (make-digest-port-name mdp))
     port ) )
 
+(: digest-output-port? (* -> boolean : digest-output-port))
+;
 (define (digest-output-port? obj)
   (and
     (output-port? obj)
-    (eq? 'digest (%port-type obj)) ) )
+    (eq? PORT-TAG (%port-type obj)) ) )
 
 (define-check+error-type digest-output-port)
 
-(define (digest-output-port-name p)
-  (%port-name (check-digest-output-port 'digest-output-port-name p)) )
+(define: (digest-output-port-name (port digest-output-port)) -> string
+  (%port-name
+    (check-digest-output-port 'digest-output-port-name port)) )
 
-;; Finalizes the digest-output-port and returns the result in the form requested
-
-(define (*close-output-digest loc digest-port result-type)
+(define: (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
   (let (
     (res
       (finalize-message-digest
-        (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
-        result-type)) )
-    (close-output-port digest-port)
+        (##sys#port-data
+          (check-open-digest-output-port loc port 'digest-port))
+        restyp)) )
+    (close-output-port port)
     res ) )
 
-(define (get-output-digest digest-port #!optional (result-type (message-digest-result-form)))
-  (*close-output-digest 'get-output-digest digest-port result-type) )
+(define: (get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type
+  (let (
+    (restyp (optional opts (message-digest-result-form))) )
+    (*close-output-digest 'get-output-digest port restyp) ) )
 
 ;;;
 
-;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP.
-;; Returns the accumulated output string | blob | u8vector | hexstring
-
-(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
+(define: (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
   (let (
+    (restyp (optional opts (message-digest-result-form)))
     (port (open-output-digest mdp)) )
     (proc port)
-    (*close-output-digest 'call-with-output-digest port result-type) ) )
+    (*close-output-digest 'call-with-output-digest port restyp) ) )
 
-;; Calls the procedure THUNK with the current-input-port temporarily bound to a
-;; digest-output-port for the MDP.
-;; Returns the accumulated output string | blob | u8vector | hexstring
-
-(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form)))
-  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
+(define: (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
+  (let (
+    (restyp (optional opts (message-digest-result-form))) )
+    (call-with-output-digest mdp (cut with-input-from-port <> thunk) restyp) ) )
 
 ) ;module message-digest

release/4/message-digest/trunk/message-digest-srfi-4.scm

@@ -64 +64 @@
 ;;; Single Source API
 
-(define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-form
+(define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
-    (result-type (message-digest-result-form))
+    (restyp (message-digest-result-form))
     (start 0)
     (end (u8vector-length u8vec)) )
     (let ((md (initialize-message-digest mdp)))
       (message-digest-update-u8vector md u8vec start end)
-      (finalize-message-digest md result-type) ) ) )
+      (finalize-message-digest md restyp) ) ) )
 
-(define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-form
+(define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-type
   (let-optionals* opts (
     (start 0)
@@ -89 +89 @@
 (: message-digest-update-packed-vector deprecated)
 (define (message-digest-update-packed-vector md pkdvec)
-  (let ((blb (packed-vector->blob/shared pkdvec)))
+  (let (
+    (blb (packed-vector->blob/shared pkdvec)) )
     (if blb
       (message-digest-update-blob md blb)
@@ -97 +98 @@
 (define (message-digest-update-bytevector md bv #!optional (len (number-of-bytes bv)))
   (check-message-digest 'message-digest-update-bytevector md)
-  (let ((mdp (message-digest-algorithm md))
-        (ctx (message-digest-context md)) )
+  (let (
+    (mdp (message-digest-algorithm md))
+    (ctx (message-digest-context md)) )
     ((message-digest-primitive-update mdp)
         ctx

release/4/message-digest/trunk/message-digest-type.scm

@@ -60 +60 @@
 ;assumes blob 'res' may not be of result size
 
-(define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
-  (case (canonical-result-name rt)
+(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
+  (case (canonical-result-name restyp)
     ((blob)           res )
     ((byte-string)    (blob->string res) )
@@ -67 +67 @@
     ((u8vector)       (blob->u8vector/shared res) )
     (else
-      (error-result-form loc rt) ) ) )
+      (error-result-form loc restyp) ) ) )
 
 #;
-(define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
-  (case rt
+(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
+  (case restyp
     ((blob)
       (if (fx= len (blob-size res)) res
@@ -86 +86 @@
           (subu8vector vec 0 len) ) ) )
     (else
-      (error-result-form loc rt) ) ) )
-
-(define: (canonical-result-name (x symbol)) -> (or boolean symbol)
+      (error-result-form loc restyp) ) ) )
+
+(define: (canonical-result-name (x message-digest-result-form)) -> (or boolean message-digest-result-form)
   (case x
     ((blob)                       'blob )
@@ -97 +97 @@
       #f ) ) )
 
-(define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-form)) -> message-digest-result-form
+(define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-type)) -> message-digest-result-type
   (let (
     (siz
@@ -119 +119 @@
 ;;
 
-(: message-digest-result-form (#!optional symbol -> symbol))
+(: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form))
 ;
 (define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string
@@ -162 +162 @@
 ;;
 
-(define: (finalize-message-digest (md message-digest) . (opts (list-of message-digest-result-form))) -> message-digest-result-form
+(define: (finalize-message-digest (md message-digest) . (opts (list message-digest-result-type))) -> message-digest-result-type
   (let* (
-    (result-type
-      (optional opts (message-digest-result-form)))
-    (mdp
-      (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
-    (res
-      (make-blob (message-digest-primitive-digest-length mdp))) )
+    (restyp (optional opts (message-digest-result-form)))
+    (mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
+    (res (make-blob (message-digest-primitive-digest-length mdp))) )
     ;side-effects res
     ((message-digest-primitive-final mdp) (message-digest-context md) res)
-    (get-result-form 'finalize-message-digest res result-type) ) )
-
-(define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-form
+    (get-result-form 'finalize-message-digest res restyp) ) )
+
+(define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-type
   (let* (
     (mdp
@@ -192 +189 @@
     (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
     ;enough space? then reuse, otherwise new buffer
-    (if buf (print "buf " buf))
     (if (and buf (fx<= sz (number-of-bytes buf)))
       buf

release/4/message-digest/trunk/message-digest-types.scm

@@ -9 +9 @@
 (define-type pathname string)
 
-(define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
+(define-type srfi4vector
+  (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
 
-;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer))
+#; ;desired, bufpointer is (pointer + length)
+(define-type message-digest-buffer
+  (or string blob srfi4vector procedure input-port bufpointer))
 (define-type message-digest-buffer (or string blob u8vector))
 
-(define-type message-digest-result-form (or string blob u8vector))
+(define-type message-digest-byte-order symbol)
+
+(define-type message-digest-result-form symbol)
+
+(define-type message-digest-result-type (or string blob u8vector))
 
 (define-type message-digest-buffer (or string blob u8vector))
@@ -23 +30 @@
 
 (define-type message-digest (struct message-digest))
+
+(define-type digest-output-port output-port)