;; Name space utilities for rpn compilers.

(module ns-utils mzscheme
  (require "ns.ss"
           "rep.ss")  ;; for ns-define! which mutates the word struct

  (provide (all-defined))  ;; utils
  
  
  ;; SYMBOL SEMANTICS
  
  ;; Run-time symbol -> code translation. The 'find' routine is
  ;; plugged into the expression (apply/force (delay (find 'name
  ;; . args))) generated by the associated source transformer. The
  ;; code below is for generating 'find' objects bound to a list of
  ;; namespace paths.

  ;; But first we define a mechanism for handling undefined
  ;; names. This behaviour is left as a parameter. By default
  ;; undefined symbols are an error.
  
  (define default-find
    (make-parameter
     (lambda args
       (error 'not-found "~a" args))))

  (define (not-found name . paths)
    (apply (default-find) name paths))


  ;; The most common alternative is to replace all undefined names
  ;; with some default behaviour.

  (define-syntax with-default-find
    (syntax-rules ()
      ((_ default expr ...)
       (parameterize
           ((default-find default))
         expr ...))))

  
  ;; Looking up a function in a list of name spaces can be abstracted
  ;; out.

  (define (lookup paths name)
    (let rest ((p paths))
      (and (not (null? p))
           (or (ns-ref `(,@(car p) ,name) #f)
               (rest (cdr p))))))



  ;; REDEFINE WORDS

  ;; In order to respect cached bindings, the word struct (box) needs
  ;; to be left in place if it already exists, and will be filled with
  ;; the value of another word.

  (define (ns-define-word! tag word)
    (let ((prev (ns-ref tag #f)))
      (ns-set! tag
               (if prev
                   (begin
                     (when (not (word? prev))
                       (error 'not-a-word "ns-define! needs word, tag = ~a" tag))
                     ;; (printf "REDEFINE: ~a\n" tag)
                     (word-become! prev word))
                   word))))



  ;; FLUSH WORDS

  (define (ns-flush-dynamic-words! path)
    (ns-remove-all!
     path
     (lambda (name word)
       ;; (printf "checking: ~a\n" name)
       (word-dynamic? word))
     (lambda (name word)
       ;; (printf "removing: ~a\n" name)
       (word-proc!
        word
        (lambda s
          (error 'stale-macro "~a" name))))))

  

  )