;;;; symbol-utils.gen.scm  -*- Scheme -*-
;;;; Kon Lovett, Oct '22

;"atomic"
(declare (disable-interrupts))

(module (symbol-utils gen)

(;export
  make-gensym)

(import scheme utf8
        (chicken base)
        (chicken fixnum)
        (chicken type))

(define-type namearg (or false symbol string))

(: make-gensym (namearg #!optional (string -> symbol) -> (#!optional namearg -> symbol)))

;;

(define (ensure-namearg loc tag)
  (cond ((not tag)      "")
        ((symbol? tag)  (symbol->string tag))
        ((string? tag)  tag)
        (else
          (error loc "bad argument - not a false, string or symbol" tag))) )

(define (make-counter #!optional (from 0))
  (let ((+cnt+ (the fixnum from)))
    (lambda ()
      ;"atomic"
      (let ((cnt +cnt+))
        (set! +cnt+ (fx+ +cnt+ 1))
        cnt))) )

;;

(define (make-gensym bas #!optional (to-sym string->uninterned-symbol))
  (let ((+bas+ (ensure-namearg 'make-gensym bas))
        (cnt++ (make-counter)) )
    (lambda (#!optional tag)
      (to-sym (string-append +bas+
                             (ensure-namearg 'make-gensym tag)
                             (number->string (cnt++)))) ) ) )

) ;module (symbol-utils gen)