home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d556 / scheme2c.lha / Scheme2C / Scheme-src.lzh / scsc / plist.sc < prev    next >
Text File  |  1991-10-11  |  3KB  |  74 lines
  1. ;;; The compilers "symbol table" is kept by recording an alist  associated
  2. ;;; with each identifier under the key SCC.  The function GET is used to
  3. ;;; access an item, and the function PUT is used to set an item.
  4. ;;;
  5. ;;; All property entries for all visible symbols (i.e. in *OBARRAY*) can be
  6. ;;; copied from one key to another by COPY-PLIST.  This is used to save and
  7. ;;; restore initial values.
  8. ;;;
  9.  
  10. ;*              Copyright 1989 Digital Equipment Corporation
  11. ;*                         All Rights Reserved
  12. ;*
  13. ;* Permission to use, copy, and modify this software and its documentation is
  14. ;* hereby granted only under the following terms and conditions.  Both the
  15. ;* above copyright notice and this permission notice must appear in all copies
  16. ;* of the software, derivative works or modified versions, and any portions
  17. ;* thereof, and both notices must appear in supporting documentation.
  18. ;*
  19. ;* Users of this software agree to the terms and conditions set forth herein,
  20. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  21. ;* right and license under any changes, enhancements or extensions made to the
  22. ;* core functions of the software, including but not limited to those affording
  23. ;* compatibility with other hardware or software environments, but excluding
  24. ;* applications which incorporate this software.  Users further agree to use
  25. ;* their best efforts to return to Digital any such changes, enhancements or
  26. ;* extensions that they make and inform Digital of noteworthy uses of this
  27. ;* software.  Correspondence should be provided to Digital at:
  28. ;* 
  29. ;*                       Director of Licensing
  30. ;*                       Western Research Laboratory
  31. ;*                       Digital Equipment Corporation
  32. ;*                       100 Hamilton Avenue
  33. ;*                       Palo Alto, California  94301  
  34. ;* 
  35. ;* This software may be distributed (but not offered for sale or transferred
  36. ;* for compensation) to third parties, provided such third parties agree to
  37. ;* abide by the terms and conditions of this notice.  
  38. ;* 
  39. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  40. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  41. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  42. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  43. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  44. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  45. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  46. ;* SOFTWARE.
  47.  
  48. (module plist)
  49.  
  50. (define (GET id key)
  51.     (let ((pl (assq key (or (getprop id 'scc) '()))))
  52.      (if pl (cdr pl) '())))
  53.  
  54. (define (PUT id key value)
  55.     (let* ((pl (or (getprop id 'scc) '()))
  56.        (oldvalue (assq key pl)))
  57.       (if oldvalue
  58.           (set-cdr! oldvalue value)
  59.           (putprop id 'scc (cons (cons key value) pl)))
  60.       value))
  61.  
  62. (define (COPY-PLIST src-key dest-key)
  63.     (do ((i (- (vector-length *obarray*) 1) (- i 1)))
  64.     ((= i -1))
  65.     (for-each
  66.         (lambda (var)
  67.             (putprop var dest-key
  68.             (let loop ((val (getprop var src-key)))
  69.                  (if (pair? val)
  70.                  (cons (loop (car val))
  71.                        (loop (cdr val)))
  72.                  val))))
  73.         (vector-ref *obarray* i))))
  74.