#| -*- Mode                : LISP;
       Package             : (BENCH-HARRIS :USE (GLOBAL RPG-BENCHMARKS)); 
       Base                : 10;
       source-optimizations: t;
   -*-
 
  Benchmark from some Harris corp division. Also a study in fancy file mode lines.
  Enhancements (C) Copyright 1983, Lisp Machine, Inc.

 |#


(timer test1 (bench 10000))

(timer test2 (bench2 10000))

(eval-when (compile)
  (defvar *avoid-eval* t "should be T if you have real lexical scoping"))

(defmacro thunk (expression)
  (cond (*avoid-eval*
	 `#'(lambda () ,expression))
	('else
	 `',expression)))

(defmacro invoke-thunk (x)
  `(,(cond (*avoid-eval* 'funcall) ('else 'eval))
    ,x))

(defun bench (number)
  (prog ()
     loop
	(cond ((zerop number) (return 'done)))
	(fput 'frame 'slot 'facet (thunk (car '(a b c))))
	(invoke-thunk (car (fget 'frame 'slot 'facet)))
	(setq number (- number 1))
	(go loop)))


(defun fget (frame slot facet)
  (compiler-let ((compiler:open-code-map-switch :always)) ; doesnt seem to matter much.
    (mapcar #'car
	    (cdr (assoc facet
			(cdr (assoc slot
				    (cdr (get frame 'frame)))))))))

(defun bench2 (number)
  (cond ((zerop number))
	(t (fput 'frame 'slot 'facet (thunk (car '(a b c))))
	   (invoke-thunk (car (fget 'frame 'slot 'facet)))
	   (bench2 (- number 1)))))


(defun fput (frame slot facet value)
  (cond ((member value (fget frame slot facet)) nil)
	(t (fassoc value
		   (fassoc facet
			   (fassoc slot
				   (fgetframe frame)))))))


(defun fgetframe (frame)
  (cond ((get frame 'frame))
	(t (putprop frame (ncons frame) 'frame))))

(defun fassoc (key a-list)
  (cond ((assoc key (cdr a-list)))
	(t (cadr (rplacd (last a-list) (ncons (ncons key)))))))