#| -*-Scheme-*-
-$Id: redpkg.scm,v 1.7 1995/01/06 00:14:12 cph Exp $
+$Id: redpkg.scm,v 1.8 1995/01/10 20:38:00 cph Exp $
Copyright (c) 1988-95 Massachusetts Institute of Technology
(let ((model-pathname (merge-pathnames filename)))
(with-values
(lambda ()
- (sort-descriptions
- (map (lambda (expression)
- (parse-package-expression expression))
- (read-package-description-file model-pathname))))
- (lambda (packages globals)
+ (sort-descriptions (read-and-parse-model model-pathname)))
+ (lambda (packages extensions globals)
(descriptions->pmodel
packages
+ extensions
(map (lambda (pathname)
(cons
(->namestring pathname)
model-pathname)))))
(define (sort-descriptions descriptions)
- (let loop
- ((descriptions descriptions)
- (packages '())
- (globals '()))
- (cond ((null? descriptions)
- (values (reverse! packages) globals))
- ((not (car descriptions))
- (loop (cdr descriptions) packages globals))
- ((package-description? (car descriptions))
- (loop (cdr descriptions)
- (cons (car descriptions) packages)
- globals))
- ((and (pair? (car descriptions))
- (eq? (caar descriptions) 'GLOBAL-DEFINITIONS))
- (loop (cdr descriptions)
- packages
- (append globals (cdr (car descriptions)))))
- ((and (pair? (car descriptions))
- (eq? (caar descriptions) 'NESTED-DESCRIPTIONS))
- (loop (append (cdr descriptions) (cdar descriptions))
- packages
- globals))
- (else
- (error "Illegal description" (car descriptions))))))
-
-(define (read-package-description-file pathname)
- (read-file (pathname-default-type pathname "pkg")))
+ (let ((packages '())
+ (extensions '())
+ (globals '()))
+ (let loop ((descriptions descriptions))
+ (for-each (lambda (description)
+ (case (car description)
+ ((DEFINE-PACKAGE)
+ (set! packages (cons (cdr description) packages)))
+ ((EXTEND-PACKAGE)
+ (set! extensions (cons (cdr description) extensions)))
+ ((GLOBAL-DEFINITIONS)
+ (set! globals
+ (append! globals (list-copy (cdr description)))))
+ ((NESTED-DESCRIPTIONS)
+ (loop (cdr description)))
+ (else
+ (error "Unknown description keyword:"
+ (car description)))))
+ descriptions))
+ (values (reverse! packages)
+ (reverse! extensions)
+ globals)))
\f
(define (read-file-analyses! pmodel)
(for-each (lambda (p&c)
\f
;;;; Package Descriptions
-(define (parse-package-expression expression)
- (if (not (pair? expression))
- (error "package expression not a pair" expression))
- (case (car expression)
- ((DEFINE-PACKAGE)
- (parse-package-description (parse-name (cadr expression))
- (cddr expression)))
- ((GLOBAL-DEFINITIONS)
- (let ((filenames (cdr expression)))
- (if (not (check-list filenames string?))
- (error "illegal filenames" filenames))
- (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
- ((OS-TYPE-CASE)
- (if (not (and (list? (cdr expression))
- (for-all? (cdr expression)
- (lambda (clause)
- (and (or (eq? 'ELSE (car clause))
- (and (list? (car clause))
- (for-all? (car clause) symbol?)))
- (list? (cdr clause)))))))
- (error "Malformed expression:" expression))
- (cons 'NESTED-DESCRIPTIONS
- (let loop ((clauses (cdr expression)))
- (cond ((null? clauses)
- '())
- ((or (eq? 'ELSE (caar clauses))
- (memq microcode-id/operating-system (caar clauses)))
- (map parse-package-expression (cdar clauses)))
- (else
- (loop (cdr clauses)))))))
- (else
- (error "unrecognized expression keyword" (car expression)))))
-
-(define (parse-package-description name options)
- (let ((none "none"))
- (let ((file-cases '())
- (parent none)
- (initialization none)
- (exports '())
- (imports '()))
- (if (not (list? options))
- (error "options not list" options))
- (for-each (lambda (option)
- (if (not (pair? option))
- (error "Illegal option" option))
- (case (car option)
- ((FILES)
- (set! file-cases
- (cons (parse-filenames (cdr option)) file-cases)))
- ((FILE-CASE)
- (set! file-cases
- (cons (parse-file-case (cdr option)) file-cases)))
- ((PARENT)
- (if (not (eq? parent none))
- (error "option reoccurs" option))
- (if (not (and (pair? (cdr option)) (null? (cddr option))))
- (error "illegal option" option))
- (set! parent (parse-name (cadr option))))
- ((EXPORT)
- (set! exports (cons (parse-export (cdr option)) exports)))
- ((IMPORT)
- (set! imports (cons (parse-import (cdr option)) imports)))
- ((INITIALIZATION)
- (if (not (eq? initialization none))
- (error "option reoccurs" option))
- (set! initialization (parse-initialization (cdr option))))
- (else
- (error "unrecognized option keyword" (car option)))))
- options)
- (make-package-description
- name
- file-cases
- (if (eq? parent none) 'NONE parent)
- (if (eq? initialization none) '#F initialization)
- (reverse! exports)
- (reverse! imports)))))
+(define (read-and-parse-model pathname)
+ (parse-package-expressions
+ (read-file (pathname-default-type pathname "pkg"))
+ pathname))
+
+(define (parse-package-expressions expressions pathname)
+ (map (lambda (expression)
+ (parse-package-expression expression pathname))
+ expressions))
+
+(define (parse-package-expression expression pathname)
+ (let ((lose
+ (lambda ()
+ (error "Ill-formed package expression:" expression))))
+ (if (not (and (pair? expression)
+ (symbol? (car expression))
+ (list? (cdr expression))))
+ (lose))
+ (case (car expression)
+ ((DEFINE-PACKAGE)
+ (cons 'DEFINE-PACKAGE
+ (parse-package-definition (parse-name (cadr expression))
+ (cddr expression))))
+ ((EXTEND-PACKAGE)
+ (cons 'EXTEND-PACKAGE
+ (parse-package-extension (parse-name (cadr expression))
+ (cddr expression))))
+ ((GLOBAL-DEFINITIONS)
+ (let ((filenames (cdr expression)))
+ (if (not (for-all? filenames string?))
+ (lose))
+ (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+ ((OS-TYPE-CASE)
+ (if (not (and (list? (cdr expression))
+ (for-all? (cdr expression)
+ (lambda (clause)
+ (and (or (eq? 'ELSE (car clause))
+ (and (list? (car clause))
+ (for-all? (car clause) symbol?)))
+ (list? (cdr clause)))))))
+ (lose))
+ (cons 'NESTED-DESCRIPTIONS
+ (let loop ((clauses (cdr expression)))
+ (cond ((null? clauses)
+ '())
+ ((or (eq? 'ELSE (caar clauses))
+ (memq microcode-id/operating-system (caar clauses)))
+ (parse-package-expressions (cdar clauses) pathname))
+ (else
+ (loop (cdr clauses)))))))
+ ((INCLUDE)
+ (cons 'NESTED-DESCRIPTIONS
+ (let ((filenames (cdr expression)))
+ (if (not (for-all? filenames string?))
+ (lose))
+ (append-map (lambda (filename)
+ (read-and-parse-model
+ (merge-pathnames filename pathname)))
+ filenames))))
+ (else
+ (lose)))))
+\f
+(define (parse-package-definition name options)
+ (check-package-options options)
+ (call-with-values
+ (lambda ()
+ (let ((option (assq 'PARENT options)))
+ (if option
+ (let ((options (delq option options)))
+ (if (not (and (pair? (cdr option))
+ (null? (cddr option))))
+ (error "Ill-formed PARENT option:" option))
+ (if (assq 'PARENT options)
+ (error "Multiple PARENT options."))
+ (values (parse-name (cadr option)) options))
+ (values 'NONE options))))
+ (lambda (parent options)
+ (let ((package (make-package-description name parent)))
+ (process-package-options package options)
+ package))))
+
+(define (parse-package-extension name options)
+ (check-package-options options)
+ (let ((option (assq 'PARENT options)))
+ (if option
+ (error "PARENT option illegal in package extension:" option)))
+ (let ((package (make-package-description name 'NONE)))
+ (process-package-options package options)
+ package))
+
+(define (check-package-options options)
+ (if (not (list? options))
+ (error "Package options must be a list:" options))
+ (for-each (lambda (option)
+ (if (not (and (pair? option)
+ (symbol? (car option))
+ (list? (cdr option))))
+ (error "Ill-formed package option:" option)))
+ options))
+
+(define (process-package-options package options)
+ (for-each (lambda (option)
+ (case (car option)
+ ((FILES)
+ (set-package-description/file-cases!
+ package
+ (append (package-description/file-cases package)
+ (list (parse-filenames (cdr option))))))
+ ((FILE-CASE)
+ (set-package-description/file-cases!
+ package
+ (append (package-description/file-cases package)
+ (list (parse-file-case (cdr option))))))
+ ((EXPORT)
+ (set-package-description/exports!
+ package
+ (append (package-description/exports package)
+ (list (parse-export (cdr option))))))
+ ((IMPORT)
+ (set-package-description/imports!
+ package
+ (append (package-description/imports package)
+ (list (parse-import (cdr option))))))
+ ((INITIALIZATION)
+ (if (package-description/initialization package)
+ (error "Multiple INITIALIZATION options:" option))
+ (set-package-description/initialization!
+ package
+ (parse-initialization (cdr option))))
+ (else
+ (error "Unrecognized option keyword:" (car option)))))
+ options))
\f
(define (parse-name name)
(if (not (check-list name symbol?))
\f
;;;; Packages
-(define (package-lookup package name)
- (let package-loop ((package package))
- (or (package/find-binding package name)
- (and (package/parent package)
- (package-loop (package/parent package))))))
-
-(define (name->package packages name)
- (list-search-positive packages
- (lambda (package)
- (symbol-list=? name (package/name package)))))
-
-(define (descriptions->pmodel descriptions globals pathname)
+(define (descriptions->pmodel descriptions extensions globals pathname)
(let ((packages
(map (lambda (description)
- (make-package
- (package-description/name description)
- (package-description/file-cases description)
- (package-description/initialization description)
- 'UNKNOWN))
+ (make-package (package-description/name description) 'UNKNOWN))
descriptions))
(extra-packages '()))
(let ((root-package
(or (name->package packages '())
- (make-package '() '() '#F false))))
+ (make-package '() #f))))
(let ((get-package
- (lambda (name)
+ (lambda (name intern?)
(if (null? name)
root-package
(or (name->package packages name)
(name->package extra-packages name)
- (let ((package (make-package name '() #F 'UNKNOWN)))
- (set! extra-packages (cons package extra-packages))
- package))))))
+ (if intern?
+ (let ((package (make-package name 'UNKNOWN)))
+ (set! extra-packages
+ (cons package extra-packages))
+ package)
+ (error "Unknown package name:" name)))))))
;; GLOBALS is a list of the bindings supplied externally.
(for-each
(lambda (global)
(let ((namestring (->namestring (car global))))
(lambda (entry)
(for-each
- (let ((package (get-package (car entry))))
+ (let ((package (get-package (car entry) #t)))
(lambda (name)
(bind! package
name
(cdr entry))))
(cdr global)))
globals)
- (for-each (lambda (package description)
- (let ((parent
- (let ((parent-name
- (package-description/parent description)))
- (and (not (eq? parent-name 'NONE))
- (get-package parent-name)))))
- (set-package/parent! package parent)
- (if parent
- (set-package/children!
- parent
- (cons package (package/children parent)))))
- (for-each (lambda (export)
- (let ((destination (get-package (car export))))
- (for-each (lambda (name)
- (link! package name
- destination name))
- (cdr export))))
- (package-description/exports description))
- (for-each (lambda (import)
- (let ((source (get-package (car import))))
- (for-each (lambda (name)
- (link! source name package name))
- (cdr import))))
- (package-description/imports description)))
- packages
- descriptions))
+ (for-each
+ (lambda (package description)
+ (let ((parent
+ (let ((parent-name (package-description/parent description)))
+ (and (not (eq? parent-name 'NONE))
+ (get-package parent-name #t)))))
+ (set-package/parent! package parent)
+ (if parent
+ (set-package/children!
+ parent
+ (cons package (package/children parent)))))
+ (process-package-description package description get-package))
+ packages
+ descriptions)
+ (for-each
+ (lambda (extension)
+ (process-package-description
+ (get-package (package-description/name extension) #f)
+ extension
+ get-package))
+ extensions))
(make-pmodel root-package
- (make-package primitive-package-name '() '() false)
+ (make-package primitive-package-name #f)
packages
extra-packages
pathname))))
+\f
+(define (package-lookup package name)
+ (let package-loop ((package package))
+ (or (package/find-binding package name)
+ (and (package/parent package)
+ (package-loop (package/parent package))))))
+
+(define (name->package packages name)
+ (list-search-positive packages
+ (lambda (package)
+ (symbol-list=? name (package/name package)))))
+
+(define (process-package-description package description get-package)
+ (let ((file-cases (package-description/file-cases description)))
+ (set-package/file-cases! package
+ (append! (package/file-cases package)
+ (list-copy file-cases)))
+ (set-package/files!
+ package
+ (append! (package/files package)
+ (append-map! (lambda (file-case)
+ (append-map cdr (cdr file-case)))
+ file-cases))))
+ (let ((initialization (package-description/initialization description)))
+ (if (and initialization
+ (package/initialization package))
+ (error "Multiple package initializations:" initialization))
+ (set-package/initialization! package initialization))
+ (for-each (lambda (export)
+ (let ((destination (get-package (car export) #t)))
+ (for-each (lambda (name)
+ (link! package name destination name))
+ (cdr export))))
+ (package-description/exports description))
+ (for-each (lambda (import)
+ (let ((source (get-package (car import) #t)))
+ (for-each (lambda (name)
+ (link! source name package name))
+ (cdr import))))
+ (package-description/imports description)))
(define primitive-package-name
(list (string->symbol "#[(cross-reference reader)primitives]")))
projects / mit-scheme.git / commitdiff