home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / PACK.SCM < prev    next >
Text File  |  1992-06-19  |  4KB  |  158 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Package setup and command definitions for Scheme48 command processor
  5.  
  6. (define-package defpackage
  7.   (open system)
  8.   (export define-package package-ref scheme defpackage))
  9.  
  10. (export! system-package
  11.      '(scheme defpackage))
  12.  
  13. (define-package record
  14.   (open system)
  15.   (export make-record-type
  16.       record-constructor
  17.       record-accessor
  18.       record-modifier
  19.       record-predicate
  20.       define-record-discloser
  21.       define-record-type
  22.       ))
  23.  
  24. (define-package table
  25.   (open system)
  26.   (export make-table
  27.       table?
  28.       table-ref
  29.       table-set!
  30.       table-walk))
  31.  
  32. (export! system-package
  33.      '(define-enumeration))
  34.  
  35. (define-package enumerated
  36.   (open system)
  37.   (export define-enumeration
  38.       enumerand->name
  39.       name->enumerand))
  40.  
  41. (define-package fluids
  42.   (open system)
  43.   (export make-fluid let-fluid fluid set-fluid!))
  44.  
  45. (define-package condition
  46.   (open system)
  47.   (export error warn
  48.       error? warning? interrupt?
  49.       ignore-errors raise with-handler
  50.       display-condition))
  51.  
  52. ; The purpose of the packages package is to map package names to packages.
  53. ; It is referenced by commands like :set-package and :load-into.
  54.  
  55. (define-package packages
  56.   (open scheme defpackage)
  57.   (access primitives system
  58.       defpackage record table enumerated fluids condition
  59.       packages
  60.       ))
  61.  
  62. (define (package-lookup-package p name)
  63.   (let ((probe (package-lookup-lightly p name)))
  64.     (if (package? probe)
  65.     probe
  66.     (error "unrecognized package name" name))))
  67.  
  68. (let ((p (package-lookup-package system-package 'packages)))
  69.   (define! p 'for-syntax package-for-syntax)
  70.   (define! p 'user user-package))
  71.  
  72.  
  73. ; Commands:
  74.  
  75. (define-command 'set-package "<package>" "go to package"
  76.   '(name)
  77.   (lambda (name) (set-current-package! (get-package name))))
  78.  
  79. (define-command 'new-package "<name> <package> ..." "make a new package"
  80.   '(name &rest name)
  81.   (lambda (name . opens)
  82.     (eval `(define-package ,name
  83.          (open ,@opens scheme))
  84.       (fluid $packages-environment))
  85.     (set-current-package! (get-package name))))
  86.  
  87. (define-command 'open-package "<package> ..." "use other package(s)"
  88.   '(&rest name)
  89.   (lambda names
  90.     (use-packages! (current-package) (map get-package names))))
  91.  
  92. (define-command 'load-into "<package> <filename> ..."
  93.   "load source file(s) into given package"
  94.   '(name &rest filename)
  95.   (lambda (name . filenames)
  96.     (let ((p (get-package name)))
  97.       (for-each (lambda (filename) (load filename p))
  98.         filenames))))
  99.  
  100. (define-command 'export "<name> ..."
  101.   "export from current package"
  102.   '(&rest name)
  103.   (lambda names
  104.     (export! (current-package) names)))
  105.  
  106. (define-command 'clear-package "<name>"
  107.   "delete all of a package's definitions"
  108.   '(name)
  109.   (lambda (name)
  110.     (clear-package! (get-package name))))
  111.  
  112. (define-command 'bound? "<name>"
  113.   "display binding of name, if any"
  114.   '(name)
  115.   (lambda (name)
  116.     (let ((port (fluid $output-port))
  117.       (probe (package-lookup-lightly (current-package) name)))
  118.       (if (name? probe) ;unbound
  119.       (write-line "Not bound" port)
  120.       (begin (display "Bound to " port)
  121.          (write probe)
  122.          (newline port))))))
  123.  
  124.  
  125. ; Auxiliaries for package commands
  126.  
  127. (define (current-package)
  128.   (fluid $package-for-commands))
  129.  
  130. (define (set-current-package! package)
  131.   (set-fluid! $package-for-commands package))
  132.  
  133.  
  134. (define $packages-environment
  135.   (make-fluid (package-lookup-package system-package 'packages)))
  136.   
  137. (define (get-package name)
  138.   (package-lookup-package (fluid $packages-environment) name))
  139.  
  140. (export! system-package '(get-package))
  141.  
  142.  
  143. ; From Richard's misc/envs.scm:
  144. ;  receive
  145. ;  return
  146. ;  sort-list sort-list!
  147. ;  p
  148. ;  vector-posq
  149. ;  format
  150. ;  make-tracking-input-port
  151. ;  make-tracking-output-port
  152. ;  make-string-input-port
  153. ;  make-string-output-port
  154. ;  fresh-line
  155. ;  current-row
  156. ;  current-column
  157. ;  string-output-port-output
  158.