71 lines
2.4 KiB
Scheme
71 lines
2.4 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; File: destruct.sch
|
|
; Description: DESTRUCTIVE benchmark from Gabriel tests
|
|
; Author: Bob Shaw, HPLabs/ATC
|
|
; Created: 8-Apr-85
|
|
; Modified: 10-Apr-85 14:54:12 (Bob Shaw)
|
|
; 23-Jul-87 (Will Clinger)
|
|
; 22-Jan-88 (Will Clinger)
|
|
; Language: Scheme
|
|
; Status: Public Domain
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
; append! is no longer a standard Scheme procedure, so it must be defined
|
|
; for implementations that don't already have it.
|
|
|
|
(define (my-append! x y)
|
|
(if (null? x)
|
|
y
|
|
(do ((a x b)
|
|
(b (cdr x) (cdr b)))
|
|
((null? b)
|
|
(set-cdr! a y)
|
|
x))))
|
|
|
|
;;; DESTRU -- Destructive operation benchmark
|
|
|
|
(define (destructive n m)
|
|
(let ((l (do ((i 10 (- i 1))
|
|
(a '() (cons '() a)))
|
|
((= i 0) a))))
|
|
(do ((i n (- i 1)))
|
|
((= i 0))
|
|
(cond ((null? (car l))
|
|
(do ((l l (cdr l)))
|
|
((null? l))
|
|
(or (car l)
|
|
(set-car! l (cons '() '())))
|
|
(my-append! (car l)
|
|
(do ((j m (- j 1))
|
|
(a '() (cons '() a)))
|
|
((= j 0) a)))))
|
|
(else
|
|
(do ((l1 l (cdr l1))
|
|
(l2 (cdr l) (cdr l2)))
|
|
((null? l2))
|
|
(set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
|
|
(a (car l2) (cdr a)))
|
|
((zero? j) a)
|
|
(set-car! a i))
|
|
(let ((n (quotient (length (car l1)) 2)))
|
|
(cond ((= n 0) (set-car! l1 '())
|
|
(car l1))
|
|
(else
|
|
(do ((j n (- j 1))
|
|
(a (car l1) (cdr a)))
|
|
((= j 1)
|
|
(let ((x (cdr a)))
|
|
(set-cdr! a '())
|
|
x))
|
|
(set-car! a i))))))))))))
|
|
|
|
;;; call: (destructive 600 50)
|
|
|
|
(let ((input (with-input-from-file "input.txt" read)))
|
|
(time (let loop ((n 10) (v 0))
|
|
(if (zero? n)
|
|
'v
|
|
(loop (- n 1)
|
|
(destructive (if input 600 0) 500))))))
|
|
|