feat: 9.5.9

mats/mat.ss

@@ -0,0 +1,578 @@
+;;; mat.ss
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;(eval-when (compile load eval) (current-expand sc-expand))
+(eval-when (compile) (optimize-level 2))
+
+(eval-when (load eval)
+  (define-syntax mat
+    (lambda (x)
+      (syntax-case x (parameters)
+        [(_ x (parameters [param val ...] ...) e ...)
+         #'(let f ([p* (list param ...)] [v** (list (list val ...) ...)])
+             (if (null? p*)
+                 (mat x e ...)
+                 (let ([p (car p*)])
+                   (for-each
+                     (lambda (v)
+                       (parameterize ([p v])
+                         (f (cdr p*) (cdr v**))))
+                     (car v**)))))]
+        [(_ x e ...)
+         (with-syntax ([(source ...)
+                        (map (lambda (clause)
+                               (let ([a (syntax->annotation clause)])
+                                 (and (annotation? a) (annotation-source a))))
+                             #'(e ...))])
+           #'(mat-run 'x '(e source) ...))]))))
+
+(define enable-cp0 (make-parameter #f))
+
+(define-syntax mat/cf
+  (syntax-rules (testfile)
+    [(_ (testfile ?path) expr ...)
+     (let* ([path ?path] [testfile.ss (format "~a.ss" path)] [testfile.so (format "~a.so" path)])
+       (with-output-to-file testfile.ss
+         (lambda () (begin (write 'expr) (newline)) ...)
+         'replace)
+       (parameterize ([generate-inspector-information #t])
+         (compile-file testfile.ss))
+       (load testfile.so)
+       #t)]
+    [(_ expr ...) (mat/cf (testfile "testfile") expr ...)]))
+
+(define mat-output (make-parameter (current-output-port)))
+
+(let ()
+
+(define mat-load
+  (lambda (in)
+    (call/cc
+      (lambda (k)
+        (parameterize ([reset-handler (lambda () (k #f))]
+                       [current-expand (current-expand)]
+                       [run-cp0
+                        (let ([default (run-cp0)])
+                          (lambda (cp0 x)
+                            (if (enable-cp0) (default cp0 x) x)))])
+          (with-exception-handler
+            (lambda (c)
+              (if (warning? c)
+                  (raise-continuable c)
+                  (begin
+                    (fprintf (mat-output) "Error reading mat input: ")
+                    (display-condition c (mat-output))
+                    (reset))))
+            (lambda () (load in))))))))
+
+(define mat-one-exp
+  (lambda (expect th sanitize-all?)
+    (define (sanitize-condition c)
+      (define sanitize
+        (lambda (arg)
+          (if sanitize-all?
+              (cond
+                [(port? arg) 'sanitized-port]
+                [else 'sanitized-unhandled-type])
+             ; go one level only to avoid getting bit by cyclic structures
+              (if (list? arg)
+                  (map sanitize1 arg)
+                  (sanitize1 arg)))))
+      (define sanitize1
+        (lambda (arg)
+         ; attempt to gloss over fixnum-size differences between
+         ; 32- and 64-bit versions
+          (cond
+            [(ftype-pointer? arg) '<ftype-pointer>]
+            [(time? arg) '<time>]
+            [(date? arg) '<date>]
+            [(and (eq? expect 'error)
+                  (real? arg)
+                  (if (>= arg 0)
+                     ; look for numbers around the size in bits or quantity
+                     ; of our 30- and 61-bit fixnums, 32 and 64-bit words
+                      (or (or (<= 28 arg 33) (<= (expt 2 28) arg (expt 2 33)))
+                          (or (<= 59 arg 65) (<= (expt 2 59) arg (expt 2 65))))
+                      (or (or (<= -33 arg -28) (<= (- (expt 2 33)) arg (- (expt 2 28))))
+                          (or (<= -65 arg -59) (<= (- (expt 2 65)) arg (- (expt 2 59)))))))
+             (if (< arg 0) '<-int> '<int>)]
+            [else arg])))
+      (let ([sc* (simple-conditions c)])
+        (cond
+          [(find irritants-condition? sc*) =>
+           (lambda (ic)
+             (let ([ls (condition-irritants ic)])
+               (if (list? ls)
+                   (apply condition (make-irritants-condition (map sanitize ls)) (remq ic sc*))
+                   c)))]
+          [else c])))
+    (define (condition-message c)
+      (define prefix?
+        (lambda (x y)
+          (let ([n (string-length x)])
+            (and (fx<= n (string-length y))
+              (let prefix? ([i 0])
+                (or (fx= i n)
+                    (and (char=? (string-ref x i) (string-ref y i))
+                         (prefix? (fx+ i 1)))))))))
+      (define prune-prefix
+        (lambda (x y)
+          (and (prefix? x y)
+               (substring y (string-length x) (string-length y)))))
+      (let ([s (call-with-string-output-port
+                 (lambda (p) (display-condition c p)))])
+        (or (prune-prefix "Exception: " s)
+            (prune-prefix "Exception in " s)
+            (prune-prefix "Warning: " s)
+            (prune-prefix "Warning in " s)
+            s)))
+    (define (condition-type c)
+      (case (fxior (if (warning? c) 1 0) (if (error? c) 2 0) (if (violation? c) 4 0))
+        [(1) 'warning]
+        [else 'error]))
+    (let ([blob '(reset . #f)])
+      (call/cc
+        (lambda (k)
+          (parameterize ([reset-handler (lambda () (k blob))])
+            (with-exception-handler
+              (lambda (c)
+                (let ([t (condition-type c)])
+                  (when (or (eq? expect 'warning) (not (eq? t 'warning)))
+                    (set! blob (cons t (condition-message (sanitize-condition c))))
+                    (reset))))
+              (lambda ()
+                (case (th)
+                  [(#t) 'true]
+                  [(#f) 'false]
+                  [else 'bogus])))))))))
+
+(define mat-error
+  (lambda (src message . args)
+    (let ([msg (apply format message args)])
+     ; strip out newlines so when we grep we get the whole message
+      (do ([i 0 (+ i 1)])
+          ((= i (string-length msg)))
+        (when (char=? (string-ref msg i) #\newline)
+          (string-set! msg i #\space)))
+      (if src
+          (let ()
+            (let ([sfd (source-object-sfd src)] [fp (source-object-bfp src)])
+              (call-with-values
+                (lambda () (#%$locate-source sfd fp #t))
+                (case-lambda
+                  [() (fprintf (mat-output) "~a at char ~a of ~a~%" msg fp (source-file-descriptor-path sfd))]
+                  [(path line char) (fprintf (mat-output) "~a at line ~a, char ~a of ~a~%" msg line char path)]))))
+          (fprintf (mat-output) "~a~%" msg))
+      (flush-output-port (mat-output)))))
+
+(define ununicode
+ ; sanitizer for expected exception messages to make sure we don't end up
+ ; with characters in mat error, experr, and report files so these files
+ ; don't end up being O/S (locale) dependent
+  (lambda (s)
+    (let ([ip (open-input-string s)] [op (open-output-string)])
+      (let f ()
+        (let ([c (read-char ip)])
+          (cond
+            [(eof-object? c) (get-output-string op)]
+            [(fx> (char->integer c) 127) (fprintf op "U+~x" (char->integer c)) (f)]
+            [else (write-char c op) (f)]))))))
+
+(define store-coverage
+  (lambda (universe-ct ct path)
+    (call-with-port
+      (open-file-output-port path
+        (file-options replace compressed)
+        (buffer-mode block)
+        (current-transcoder))
+      (lambda (op)
+        (put-source-table op
+          (if (eq? universe-ct ct)
+              ct
+              (let ([new-ct (make-source-table)])
+                (for-each
+                  (lambda (p)
+                    (let ([src (car p)] [count (cdr p)])
+                      (when (source-table-contains? universe-ct src)
+                        (source-table-set! new-ct src count))))
+                  (source-table-dump ct))
+                new-ct)))))))
+
+(define load-coverage
+  (lambda (ct)
+    (lambda (path)
+      (call-with-port
+        (open-file-input-port path
+          (file-options compressed)
+          (buffer-mode block)
+          (current-transcoder))
+        (lambda (ip) (get-source-table! ip ct +))))))
+
+(set! coverage-table (make-parameter #f))
+
+(set! mat-file
+  (lambda (dir)
+    (unless (string? dir)
+      (errorf 'mat-file "~s is not a string" dir))
+    (unless (file-exists? dir) (mkdir dir))
+    (lambda (mat)
+      (unless (string? mat)
+        (errorf 'mat-file "~s is not a string" mat))
+      (let ([ifn (format "~a.ms" mat)] [ofn (format "~a.mo" mat)])
+        (parameterize ([current-directory dir]
+                       [source-directories (cons ".." (source-directories))]
+                       [library-directories (cons ".." (library-directories))])
+          (printf "matting ~a with output to ~a/~a~%" ifn dir ofn)
+          (delete-file ofn #f)
+          (parameterize ([mat-output (open-output-file ofn)])
+            (dynamic-wind
+                (lambda () #f)
+                (lambda ()
+                  (let ([go (lambda () (mat-load ifn))] [universe-ct (coverage-table)])
+                    (if universe-ct
+                        (let-values ([(ct . ignore) (with-profile-tracker go)])
+                          (store-coverage universe-ct ct (format "~a.covout" mat)))
+                        (go))))
+                (lambda () (close-output-port (mat-output))))))))))
+
+(set! record-run-coverage
+  (lambda (covout th)
+    (let ([universe-ct (coverage-table)])
+      (if universe-ct
+          (let-values ([(ct . ignore) (with-profile-tracker #t th)])
+            (store-coverage universe-ct ct covout))
+          (th)))))
+
+(set! load-coverage-files
+  (lambda path*
+    (let ([ct (make-source-table)])
+      (for-each (load-coverage ct) path*)
+      ct)))
+
+(set! combine-coverage-files
+  (lambda (covout covout*)
+    (let ([ct (make-source-table)])
+      (for-each (load-coverage ct) covout*)
+      (store-coverage ct ct covout))))
+
+(set! coverage-percent
+  (lambda (covout . covin*)
+    (let ([n (source-table-size (load-coverage-files covout))]
+          [d (source-table-size (apply load-coverage-files covin*))])
+      (printf "~a: covered ~s of ~s source expressions (~s%)\n"
+        covout n d (round (/ (* n 100) d))))))
+
+(set! mat-run
+  (case-lambda
+    [(name)
+     (fprintf (mat-output) "Warning: empty mat for ~s.~%" name)]
+    [(name . clauses)
+     (fprintf (mat-output) "~%Starting mat ~s.~%" name)
+     ; release counters for reclaimed code objects between mat groups to reduce gc time
+     (when (compile-profile) (profile-release-counters))
+     (do ([clauses clauses (cdr clauses)]
+          [count 1 (+ count 1)])
+       ((null? clauses) 'done)
+       (let ([clause (caar clauses)] [source (cadar clauses)])
+         (with-exception-handler
+           (lambda (c)
+             (if (warning? c)
+                 (raise-continuable c)
+                 (begin
+                   (fprintf (mat-output) "Error printing mat clause: ")
+                   (display-condition c (mat-output))
+                   (reset))))
+           (lambda ()
+             (pretty-print clause (mat-output))
+             (flush-output-port (mat-output))))
+         (if (and (list? clause)
+                  (= (length clause) 2)
+                  (memq (car clause) '(sanitized-error? error? warning?)))
+             (let ([expect (case (car clause) [(sanitized-error? error?) 'error] [(warning?) 'warning])])
+               (if (and (= (optimize-level) 3) (eq? expect 'error))
+                   (fprintf (mat-output) "Ignoring error check at optimization level 3.~%")
+                   (let ([ans (mat-one-exp expect (lambda () (eval (cadr clause))) (eq? (car clause) 'sanitized-error?))])
+                     (cond
+                       [(and (pair? ans) (eq? (car ans) expect))
+                        (fprintf (mat-output)
+                          "Expected ~s in mat ~s: \"~a\".~%"
+                          expect name (ununicode (cdr ans)))]
+                       [else
+                         (mat-error source "Bug in mat ~s clause ~s" name count)]))))
+             (let ([ans (mat-one-exp #f (lambda () (eval clause)) #f)])
+               (cond
+                 [(pair? ans)
+                  (mat-error source
+                    "Error in mat ~s clause ~s: \"~a\""
+                    name
+                    count
+                    (cdr ans))]
+                 [(eq? ans 'false)
+                  (mat-error source
+                    "Bug in mat ~s clause ~s"
+                    name
+                    count)]
+                 [(eq? ans 'true) (void)]
+                 [else
+                  (mat-error source
+                    "Bug (nonboolean, nonstring return value) in mat ~s clause ~s"
+                    name
+                    count)])))))]))
+
+ );let
+
+(define equivalent-expansion?
+ ; same modulo renaming of gensyms
+ ; procedure in either input is used as predicate for other
+  (lambda (x y)
+    (let ([alist '()] [oops? #f])
+      (or (let e? ([x x] [y y])
+            (or (cond
+                  [(procedure? x) (x y)]
+                  [(procedure? y) (y x)]
+                  [(eqv? x y) #t]
+                  [(pair? x)
+                   (and (pair? y) (e? (car x) (car y)) (e? (cdr x) (cdr y)))]
+                  [(or (and (gensym? x) (symbol? y))
+                       (and (gensym? y) (symbol? x)))
+                   (cond
+                     [(assq x alist) => (lambda (a) (eq? y (cdr a)))]
+                     [else (set! alist (cons `(,x . ,y) alist)) #t])]
+                  [(string? x) (and (string? y) (string=? x y))]
+                  [(bytevector? x) (and (bytevector? y) (bytevector=? x y))]
+                  [(vector? x)
+                   (and (vector? y)
+                        (fx= (vector-length x) (vector-length y))
+                        (let f ([i (fx- (vector-length x) 1)])
+                          (or (fx< i 0)
+                              (and (e? (vector-ref x i) (vector-ref y i))
+                                   (f (fx1- i))))))]
+                  [(fxvector? x)
+                   (and (fxvector? y)
+                        (fx= (fxvector-length x) (fxvector-length y))
+                        (let f ([i (fx- (fxvector-length x) 1)])
+                          (or (fx< i 0)
+                              (and (fx= (fxvector-ref x i) (fxvector-ref y i))
+                                   (f (fx1- i))))))]
+                  [(box? x) (and (box? y) (e? (unbox x) (unbox y)))]
+                  [else #f])
+                (begin
+                  (unless oops?
+                    (set! oops? #t)
+                    (printf "failure in equivalent-expansion?:\n")
+                    (pretty-print x)
+                    (printf "is not equivalent to\n")
+                    (pretty-print y))
+                  #f)))
+          (begin
+            (printf "original expressions:\n")
+            (pretty-print x)
+            (printf "is not equivalent to\n")
+            (pretty-print y)
+            #f)))))
+
+(define *fuzz* 1e-14)
+
+(define ~=
+   (lambda (x y)
+      (or (= x y)
+          (and (fl~= (inexact (real-part x))
+                     (inexact (real-part y)))
+               (fl~= (inexact (imag-part x))
+                     (inexact (imag-part y)))))))
+
+(define fl~=
+   (lambda (x y)
+      (cond
+         [(and (fl>= (flabs x) 2.0) (fl>= (flabs y) 2.0))
+          (fl~= (fl/ x 2.0) (fl/ y 2.0))]
+         [(and (fl< 0.0 (flabs x) 1.0) (fl< 0.0 (flabs y) 1.0))
+          (fl~= (fl* x 2.0) (fl* y 2.0))]
+         [else (let ([d (flabs (fl- x y))])
+                  (or (fl<= d *fuzz*)
+                      (begin (printf "fl~~=: ~s~%" d) #f)))])))
+
+(define cfl~=
+   (lambda (x y)
+      (and (fl~= (cfl-real-part x) (cfl-real-part y))
+           (fl~= (cfl-imag-part x) (cfl-imag-part y)))))
+
+; from ieee.ms
+(define ==
+   (lambda (x y)
+      (and (inexact? x)
+           (inexact? y)
+           (if (flonum? x)
+               (and (flonum? y)
+                    (if (fl= x y)
+                        (fl= (fl/ 1.0 x) (fl/ 1.0 y))
+                        (and (not (fl= x x)) (not (fl= y y)))))
+               (and (not (flonum? y))
+                    (== (real-part x) (real-part y))
+                    (== (imag-part x) (imag-part y)))))))
+
+(define (nan) (/ 0.0 0.0))  ; keeps "pretty-equal?" happy
+(define pi (* (asin 1.0) 2))
+(define +pi   3.14159265358979323846264)
+(define +pi/2 1.57079632679489661923132)
+(define +pi/4  .78539816339744830961566)
+(define -pi (- +pi))
+(define -pi/2 (- +pi/2))
+(define -pi/4 (- +pi/4))
+
+; smallest ieee flonum
+(define +e 4.940656458412465e-324)
+(define -e (- +e))
+
+(define patch-exec-path
+  (lambda (p)
+    (if (windows?)
+        (list->string (subst #\\ #\/ (string->list p)))
+        p)))
+
+(module separate-eval-tools (separate-eval run-script separate-compile)
+  (define (slurp ip)
+    (with-output-to-string
+      (lambda ()
+        (let f ()
+          (let ([c (read-char ip)])
+            (unless (eof-object? c)
+              (write-char c)
+              (f)))))))
+  (define ($separate-eval who expr*)
+    (let-values ([(to-stdin from-stdout from-stderr pid)
+                  (open-process-ports (format "~a -q" (patch-exec-path *scheme*))
+                    (buffer-mode block)
+                    (native-transcoder))])
+      (pretty-print `(#%$enable-check-prelex-flags ,(#%$enable-check-prelex-flags)) to-stdin)
+      (for-each (lambda (expr) (pretty-print expr to-stdin)) expr*)
+      (close-port to-stdin)
+      (let* ([stdout-stuff (slurp from-stdout)]
+             [stderr-stuff (slurp from-stderr)])
+        (when (string=? stderr-stuff "")
+          (printf "$separate-eval command succeeded with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff))
+        (unless (string=? stderr-stuff "")
+          (printf "$separate-eval command failed with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff)
+          (errorf who "~a" stderr-stuff))
+        (close-port from-stdout)
+        (close-port from-stderr)
+        stdout-stuff)))
+  (define (separate-eval . expr*) ($separate-eval 'separate-eval expr*))
+  (define (run-script script)
+    (let-values ([(to-stdin from-stdout from-stderr pid)
+                  (open-process-ports
+                    (if (windows?)
+                        (format "~a --script ~a" (patch-exec-path *scheme*) script)
+                        script)
+                    (buffer-mode block)
+                    (native-transcoder))])
+      (close-port to-stdin)
+      (let* ([stdout-stuff (slurp from-stdout)]
+             [stderr-stuff (slurp from-stderr)])
+        (unless (string=? stderr-stuff "")
+          (errorf 'run-script "~a" stderr-stuff))
+        (close-port from-stdout)
+        (close-port from-stderr)
+        stdout-stuff)))
+  (define separate-compile
+    (case-lambda
+      [(x) (separate-compile 'compile-file x)]
+      [(cf x) ($separate-eval 'separate-compile `((,cf ,(if (symbol? x) (format "testfile-~a" x) x))))])))
+
+(import separate-eval-tools)
+
+#;(collect-request-handler
+  (begin
+    (warning #f "installing funky collect request-handler")
+    (lambda ()
+      (collect)
+      (when (= (random 100) 17)
+        (collect-maximum-generation (+ (random 254) 1))))))
+
+(define windows?
+  (if (memq (machine-type) '(i3nt ti3nt a6nt ta6nt))
+      (lambda () #t)
+      (lambda () #f)))
+
+(define embedded?
+  (lambda () #f))
+
+(define ($record->vector x)
+  (let* ([rtd (#%$record-type-descriptor x)]
+         [n (length (csv7:record-type-field-names rtd))]
+         [v (make-vector (fx+ n 1) (record-type-name rtd))])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i n))
+      (vector-set! v (fx+ i 1) ((csv7:record-field-accessor rtd i) x)))
+    v))
+
+(define $cat_flush "./cat_flush")
+
+(define test-cp0-expansion
+  (rec test-cp0-expansion
+    (case-lambda
+      [(expr expected) (test-cp0-expansion equivalent-expansion? expr expected)]
+      [(equiv? expr expected)
+       (let ([actual (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                       (expand/optimize `(let () (import scheme) ,expr)))])
+         (unless (equiv? actual expected)
+           (errorf 'test-cp0-expansion "expected ~s for ~s, got ~s\n" expected expr actual))
+         #t)])))
+
+(define rm-rf
+  (lambda (path)
+    (when (file-exists? path)
+      (let f ([path path])
+        (if (file-directory? path)
+            (begin
+              (for-each (lambda (x) (f (format "~a/~a" path x))) (directory-list path))
+              (delete-directory path))
+            (delete-file path))))))
+
+(define mkfile
+  (lambda (filename . expr*)
+    (with-output-to-file filename
+      (lambda () (for-each pretty-print expr*))
+      'replace)))
+
+(define touch
+  (lambda (objfn srcfn)
+    (let loop ()
+      (let ([p (open-file-input/output-port srcfn (file-options no-fail no-truncate))])
+        (put-u8 p (lookahead-u8 p))
+        (close-port p))
+      (when (file-exists? objfn)
+        (unless (time>? (file-modification-time srcfn) (file-modification-time objfn))
+          (sleep (make-time 'time-duration 1000000 1))
+          (loop))))
+    #t))
+
+(define preexisting-profile-dump-entry?
+  (let ([ht (make-eq-hashtable)])
+    (for-each (lambda (x) (eq-hashtable-set! ht (car x) #t)) (profile-dump))
+    (lambda (x) (eq-hashtable-contains? ht (car x)))))
+
+(define heap-check-interval (make-parameter 0))
+
+(collect-request-handler
+  (let ([counter 0])
+    (lambda ()
+      (parameterize ([#%$enable-check-heap
+                       (let ([interval (heap-check-interval)])
+                         (and (not (fx= interval 0))
+                              (let ([n (fxmod (fx+ counter 1) interval)])
+                                (set! counter n)
+                                (fx= n 0))))])
+        (collect)))))