(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "CONTEXT" (USE "LISP" "PT") (NICKNAMES "CT")
 (PREFIX-NAME "CT")) BASE 10)

(il:filecreated "26-Nov-88 18:51:43" il:{qv}<idl>next>contexts.\;2
 4353   

      il:|changes| il:|to:|  (il:vars il:contextscoms) (xcl:file-environments "CONTEXTS") (il:structures dataset context)
 (il:variables *dataset* *all-datasets* *dataset-hash-table* *context* *all-contexts* *context-hash-table*)
 (il:functions print-dataset make-dataset find-dataset define-dataset intern-object unintern-object find-object find-all-objects object-datasets map-dataset print-context make-context find-context define-context object-contexts map-context)
 (il:define-types datasets contexts) (contexts "MISCELLANEOUS")

      il:|previous| il:|date:| "26-Nov-88 18:50:08" il:{qv}<idl>next>contexts.\;1)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:contextscoms)

(il:rpaqq il:contextscoms ((il:variables *context* *all-contexts* *context-hash-table*) (il:structures context) (il:functions print-context make-context find-context) (il:define-types contexts) (il:functions define-context) (il:functions intern-object unintern-object find-object find-all-objects object-contexts map-context) (eval-when (compile load) (il:p (export (quote (*context* context context-p context-name context-nicknames define-context intern-object unintern-object find-object find-all-objects object-contexts map-context)) (find-package "CONTEXT")))) (xcl:file-environments "CONTEXTS")))

(defvar *context* nil)

(defvar *all-contexts* nil)

(defvar *context-hash-table* (make-hash-table :test (function equal)))

(defstruct (context (:constructor %make-context) (:copier nil) (:print-function print-context)) name nicknames (il:* il:|;;| "will be an assoc list, to effect a 2-way mapping") contents)

(defun print-context (context stream print-level) (declare (ignore print-level)) (write-string "#<Context " stream) (princ (context-name context) stream) (write-string ">" stream))

(defun make-context (name &key nicknames) (let ((context (or (gethash name *context-hash-table*) (%make-context :name name :nicknames nicknames)))) (pushnew context *all-contexts*) (setf (gethash name *context-hash-table*) context) (dolist (nickname nicknames) (setf (gethash nickname *context-hash-table*) context))))

(defun find-context (name) (values (gethash name *context-hash-table*)))

(xcl:def-define-type contexts "IDL context(s)")

(xcl:defdefiner define-context contexts (name &optional nicknames) (il:bquote (eval-when (compile load eval) (make-context (il:\\\, name) :nicknames (quote (il:\\\, nicknames))))))

(defun intern-object (name object &optional (context *context*)) (let* ((assoc-list (context-contents context)) (value-cons (assoc name assoc-list :test (function equal)))) (if value-cons (error "There already exists an object by the name ~s in this context: ~s" name context) (push (cons name object) (context-contents context))) name))

(defun unintern-object (name &optional (context *context*)) (let* ((assoc-list (context-contents context)) (value-cons (assoc name assoc-list :test (function equal)))) (if value-cons (setf (context-contents context) (delete value-cons assoc-list))) (cdr value-cons)))

(defun find-object (name &optional (context *context*)) (cdr (assoc name (context-contents context) :test (function equal))))

(defun find-all-objects (name) (mapcan (function (lambda (context) (let ((object (find-object name context))) (if object (list object))))) *all-contexts*))

(defun object-contexts (object) (mapcan (function (lambda (context) (if (rassoc object (context-contents context)) (list context)))) *all-contexts*))

(defun map-context (fn &optional (context *context*)) (dolist (pair (context-contents context)) (funcall fn (car pair) (cdr pair))))
(eval-when (compile load)

(export (quote (*context* context context-p context-name context-nicknames define-context intern-object unintern-object find-object find-all-objects object-contexts map-context)) (find-package "CONTEXT"))
)

(xcl:define-file-environment "CONTEXTS" :package (xcl:defpackage "CONTEXT" (:use "LISP" "PT") (:nicknames "CT") (:prefix-name "CT")) :readtable "XCL" :base 10 :compiler :compile-file)
(il:putprops il:contexts il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop