"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/tools/tread.scm" (9 Jul 2020, 3820 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 (load "write.scm")
    2 (load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))
    3 
    4 (set! (*s7* 'print-length) 8) ; :readable should ignore this
    5 (set! (*s7* 'default-hash-table-length) 4)
    6 ;(set! (*s7* 'heap-size) (* 10 1024000))
    7 
    8 (define (tester)
    9   (do ((baddies 0)
   10        (size 3 (+ size 1)))
   11       ((= size 4))
   12     (format *stderr* "~%-------- ~D --------~%" size)
   13     
   14     (do ((tries (* 2000 (expt 3 size)))
   15      (k 0 (+ k 1)))
   16     ((or (= k tries)
   17          (> baddies 1)))
   18       
   19       (let ((cp-lst (make-list 3 #f))
   20         (it-lst (make-list 3 #f)))
   21     (let ((bases (vector (make-list 3 #f)
   22                  (make-vector 3 #f)
   23                  (make-cycle #f)
   24                  (hash-table 'a 1 'b 2 'c 3)
   25                  (inlet 'a 1 'b 2 'c 3)
   26                  (make-iterator it-lst)
   27                  (c-pointer 1 cp-lst)))
   28           (sets ())
   29           (b1 0)
   30           (b2 0))
   31       
   32       (do ((i 0 (+ i 1))
   33            (r1 (random 7) (random 7))
   34            (r2 (random 7) (random 7))
   35            (loc (random 3) (random 3)))
   36           ((= i size))
   37         (set! b1 (bases r1))
   38         (set! b2 (bases r2))
   39         (case (type-of b1)
   40           ((pair?)
   41            (if (> (random 10) 3)
   42            (begin
   43              (set! (b1 loc) b2)
   44              (set! sets (cons (list r1 loc r2) sets)))
   45            (begin
   46              (set-cdr! (list-tail b1 2) (case loc ((0) b1) ((1) (cdr b1)) (else (cddr b1))))
   47              (set! sets (cons (list r1 (+ loc 3) r2) sets)))))
   48           
   49           ((vector?)
   50            (set! (b1 loc) b2)
   51            (set! sets (cons (list r1 loc r2) sets)))
   52           
   53           ((c-object?)
   54            (set! (b1 0) b2)
   55            (set! sets (cons (list r1 0 r2) sets)))
   56           
   57           ((hash-table? let?)
   58            (let ((key (#(a b c) loc)))
   59          (set! (b1 key) b2)
   60          (set! sets (cons (list r1 key r2) sets))))
   61           
   62           ((c-pointer?)
   63            (set! (cp-lst loc) b2)
   64            (set! sets (cons (list r1 loc r2) sets)))
   65           
   66           ((iterator?)
   67            (set! (it-lst loc) b2)
   68            (set! sets (cons (list r1 loc r2) sets)))))
   69 
   70       (let ((bi 0))
   71         (for-each 
   72          (lambda (x)
   73            (let ((str (object->string x :readable)))
   74          (unless (equal? x (eval-string str))
   75            (set! baddies (+ baddies 1))
   76            (format *stderr* "x: ~S~%" x)
   77            (format *stderr* "ex: ~S~%" (eval-string str))
   78            (format *stderr* "sets: ~S~%" (reverse sets))
   79            (format *stderr* "str: ~S~%" str)
   80            (pretty-print (with-input-from-string str read) *stderr* 0)
   81            (format *stderr* "~%~%")
   82            
   83            (format *stderr* "
   84                      (let ((p (make-list 3 #f))
   85                            (v (make-vector 3 #f))
   86                            (cy (make-cycle #f))
   87                            (h (hash-table 'a 1 'b 2 'c 3))
   88                            (e (inlet 'a 1 'b 2 'c 3))
   89                            (it (make-iterator (make-list 3 #f)))
   90                            (cp (c-pointer 1 (make-list 3 #f))))
   91                            ")
   92            (for-each
   93             (lambda (set)
   94               (cond ((and (zero? (car set))
   95                   (> (cadr set) 2))
   96                  (format *stderr* "  (set-cdr! (list-tail p 2) ~A)~%" 
   97                      (#("p" "(cdr p)" "(cddr p)") (- (cadr set) 3))))
   98                 ((< (car set) 5)
   99                  (format *stderr* "  (set! (~A ~A) ~A)~%" 
  100                      (#(p v cy h e) (car set))
  101                      (case (car set) 
  102                        ((0 1) (cadr set))
  103                        ((2) 0)
  104                        ((3) (format #f "~W" (cadr set)))
  105                        ((4) (symbol->keyword (cadr set))))
  106                      (#(p v cy h e it cp) (caddr set))))
  107                 ((= (car set) 5)
  108                  (format *stderr* "  (set! ((iterator-sequence it) ~A) ~A)~%" 
  109                      (cadr set) 
  110                      (#(p v cy h e it cp) (caddr set))))
  111                 (else (format *stderr* "  (set! (((object->let cp) 'c-type) ~A) ~A)~%" 
  112                       (cadr set)
  113                       (#(p v cy h e it cp) (caddr set))))))
  114             sets)
  115            (format *stderr* "  ~A)~%" (#(p v cy h e it cp) bi)))
  116          (set! bi (+ bi 1))))
  117          bases)))))))
  118 
  119 (tester)
  120 
  121 (when (> (*s7* 'profile) 0)
  122   (show-profile 200))
  123 (exit)