;; This contains all the code necessary for creating definitions in base.ss 

(module primitive mzscheme

  ;; this implements:
  (provide as-push as-void   ;; wrap scheme function -> cat primitive
           snarf             ;; name space registration + low level tx

           ;; pn-primitive   ;; create manual cat primitive functions, any namespace
           define-word       ;; old style primitive macro, bound to (cat) namespace


           pn-lambda-annotate  ;; like lambda, but named with source annotation
           make-scheme-word    ;; wrap any expression that generates a procedure

           )

  (require "ns.ss"         ;; name space
           "rep.ss"        ;; representation
           "rpn-snarf.ss"
           )

  (require-for-syntax "tx-utils.ss")


  
  ;; NAME


  ;; direct snarfs
  
  (define-syntax snarf-word
    (syntax-rules ()
      ((_ tx (ns ...) a (to from)) (ns-set! '(ns ... to) (tx from . a)))
      ((_ tx (ns ...) a fn)        (snarf-word tx (ns ...) a (fn fn)))))
    
  (define-syntax snarf-row
    (syntax-rules ()
      ((_ tx (catspace ...)
          (formals (fn/tofrom ...)))

       (begin
         (snarf-word tx (catspace ...) formals fn/tofrom) ...))))

  (define-syntax snarf 
    (syntax-rules ()
      ((_ tx catspace
          (formals (fn ...)) ...)
       (begin
         (snarf-row tx catspace
                    (formals (fn ...))) ...))))

  
  ;; A macro for building primitive combinators. These are in polish
  ;; notation.
 
  (define-syntax pn-primitive
    (syntax-rules ()
      ((_ (ns ...)
          (name formals body ...) ...)
       (begin
         ;; (printf "~s\n" '((ns ...) (name formals body ...) ...))
         (ns-set! '(ns ... name)
                  (make-scheme-word
                   (lambda formals body ...))) ...))))



  ;; COMPAT
  
  ;; Old style definer. These words go into the '(base)' namespace.
  
  (define-syntax define-word
    (syntax-rules ()
      ((_ name formals body ...)
       (pn-primitive (base) (name formals body ...)))))


  
)