(* File: {PHYLUM}<DESRIVIERES>NLISP>SM-BINDING in Gacha 10. *)

(* Last edited: Oct. 27, 1983 by Jim des Rivieres  *)

(* Uses: {PHYLUM}<LISP>LIBRARY>CMLSPECIALFORMS.DCOM *)

(* The global environment, which is the tail of EVERY 
   environment, is kept in a separate hash array. *)

(globalvars global-env global-env-hash-array)

(* In BINDING, var is an atom and env is a list
   of contours.  Each contour is a two element list.
   The first element is a rail of variables.  The
   second is a rail of corresponding values. *)

(defun binding (var env)
  (prog (contour var-list val-list)

   next-contour
     (if (null env) then
         (go global-binding))
     (setq contour (car env))
     (setq env (cdr env))
     (setq var-list (car contour))
     (setq val-list (cadr contour))

   next-binding-this-contour
     (if (empty? var-list) then
         (go next-contour))
     (if (equal (extract-atom (first var-list)) var) then
         (setq result (first val-list))
         (go success))
     (setq var-list (rest var-list))
     (setq val-list (rest val-list))
     (go next-binding-this-contour)

   global-binding
     (setq val (gethash var global-env-hash-array))
     (if (null val) then
         (go failure))
     (if (eq val 'nil.surrogate) then 
         (setq result nil)
     else 
         (setq result val))
     (go success)

   success
     (return result)

   failure
     (return 'not.found)))


(* In GLOBAL-BINDING is for convenience. *)

(defun global-binding (var)
   (binding var global-env))
   
(defun global-rebind (var val)
  (if (null val) then
      (puthash var 'nil.surrogate global-env-hash-array)
   else
      (puthash var val global-env-hash-array)))

(defun show-globals ()
  (maphash global-env-hash-array
    (function 
      (lambda (val var)
         (printout nil var " : "
             (export (if (eq val 'nil.surrogate) then 
                            nil else val))
             t)))))
            

(* BIND does a simple pattern match of PAT against
   ARGS.  If their is a match, the result is ENV
   augmented with new bindings.  If the match fails
   for any reason, 'NO.MATCH is returned.  Moreover,
   failure propagates; i.e., if ENV is 'NO.MATCH
   BIND automatically fails.  

   Acceptable patterns are 3-LISP atoms, and rails
   thereof.  Note that nested rail patterns are not
   allowed.

*)

(defun bind (pat args env)
   (cond
     ((equal env 'no.match) env)
     ((atom? pat)
      (cons (list (prep pat (rcons0)) 
                  (prep args (rcons0)))
            env))
     ((and (rail? pat)
           (rail? args)
           (equal (rlength pat) (rlength args)))
      (cons (list pat args) env))
     (t 'no.match)))



STOP