;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                    ;;
;;    definech.scm (h as hygienic)                                    ;;
;;                                                                    ;;
;;    Macro definec for defining cached unary (integer) functions     ;;
;;    This one is using the hygienic macro (define-syntax), and is    ;;
;;    to be used with MIT Scheme from the release 7.7.0 onward.       ;;
;;                                                                    ;;
;;    This version coded 17. July 2002                                ;;
;;                                                                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;; define unary cached functions. Syntax is like
;; (define (func arg) ...) of Scheme.


;; Added this 10. July 2002 to avoid allocation catastrophes
;; caused by the careless use of cached integer functions:
(define *MAX-CACHE-SIZE-FOR-DEFINEC* 290512) ;; Was 131072


(define-syntax definec
  (syntax-rules ()
   ((definec (name arg) e0 ...)
      (define name
        (letrec
           ((_cache_ (vector #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))
            (name
             (lambda (arg)
               (cond ((null? arg) _cache_)
                     ((>= arg *MAX-CACHE-SIZE-FOR-DEFINEC*)
                          e0 ...
                     )
                     (else
                         (if (>= arg (vector-length _cache_))
                             (set! _cache_
                                   (vector-grow
                                           _cache_
                                           (min *MAX-CACHE-SIZE-FOR-DEFINEC*
                                                (max (1+ arg)
                                                     (* 2 (vector-length _cache_))
                                                )
                                           )
                                   )
                             )
                         )
                         (or (vector-ref _cache_ arg)
                             ((lambda (res)
                                (vector-set! _cache_ arg res)
                                res
                              )
                               (begin e0 ...)
                             )
                         )
                     )
               ) ; cond
             )
            )
           ) ; letrec-definitions
          name
        ) ; letrec
      ) ;; (define name ...)
   )
  ) ;; syntax-rules
)

;; We need this file loaded when we compile other modules,
;; so it's nice to have this auxiliary function here.
;; (We can say just e.g. (compile "gatomorf") instead of
;;  all that verbose stuff:)
(define (compile filename)
  (fluid-let ((sf/default-syntax-table user-initial-environment))
     (cf filename)
  )
)