#| -*-Scheme-*-
-$Id: make.scm,v 14.94 2004/10/28 03:21:23 cph Exp $
+$Id: make.scm,v 14.95 2004/10/28 19:38:09 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
'(("prop1d" . (RUNTIME 1D-PROPERTY))
("events" . (RUNTIME EVENT-DISTRIBUTOR))
("gdatab" . (RUNTIME GLOBAL-DATABASE))
- ("gcfinal" . (RUNTIME GC-FINALIZER))))
+ ("gcfinal" . (RUNTIME GC-FINALIZER))
+ ("string" . (RUNTIME STRING))))
(load-files
(lambda (files)
(do ((files files (cdr files)))
(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
(package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t)
+ (package-initialize '(RUNTIME STRING) 'INITIALIZE-PACKAGE! #t)
;; Load everything else.
((lexical-reference environment-for-package 'LOAD-PACKAGES-FROM-FILE)
(RUNTIME WORKING-DIRECTORY)
(RUNTIME LOAD)
(RUNTIME UNICODE)
+ (RUNTIME SIMPLE-FILE-OPS)
((RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES! #f)
;; Syntax
(RUNTIME NUMBER-PARSER)
(RUNTIME STARBASE-GRAPHICS)
(RUNTIME X-GRAPHICS)
(RUNTIME OS2-GRAPHICS)
- (RUNTIME STRING)
;; Emacs -- last because it installs hooks everywhere which must be initted.
(RUNTIME EMACS-INTERFACE)
;; More debugging
#| -*-Scheme-*-
-$Id: pathnm.scm,v 14.39 2004/10/28 03:21:47 cph Exp $
+$Id: pathnm.scm,v 14.40 2004/10/28 19:38:13 cph Exp $
Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
(or (%pathname-name pathname) name)
(or (%pathname-type pathname) type)
(or (%pathname-version pathname) version))))
-
-(define (pathname-mime-type pathname)
- (let ((suffix (pathname-type pathname)))
- (and (string? suffix)
- (let ((type (os/suffix-mime-type suffix)))
- (and type
- (begin
- (guarantee-string type 'PATHNAME-MIME-TYPE)
- (let ((parts (burst-string type #\/ #f)))
- (if (not (and (pair? parts)
- (mime-token? (car parts))
- (pair? (cdr parts))
- (mime-token? (cadr parts))
- (null? (cddr parts))))
- (error "Malformed MIME-type string:" type))
- (cons (intern (car parts))
- (intern (cadr parts))))))))))
-
-(define (mime-token? string)
- (let ((end (string-length string)))
- (let loop ((i 0))
- (or (fix:= i end)
- (and (char-set-member? char-set:mime-token (string-ref string i))
- (loop (fix:+ i 1)))))))
-
-(define char-set:mime-token)
-(define (initialize-mime-token!)
- (set! char-set:mime-token
- (char-set-difference (ascii-range->char-set #x21 #x7F)
- (string->char-set "()<>@,;:\\\"/[]?=")))
- unspecific)
\f
;;;; Pathname Syntax
(define (initialize-package!)
(reset-package!)
- (add-event-receiver! event:after-restore reset-package!)
- (initialize-mime-token!))
\ No newline at end of file
+ (add-event-receiver! event:after-restore reset-package!))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.502 2004/10/28 03:21:59 cph Exp $
+$Id: runtime.pkg,v 14.503 2004/10/28 19:38:18 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
(files "sfile")
(parent (runtime))
(export ()
+ <mime-type>
allocate-temporary-file
call-with-temporary-file-pathname
call-with-temporary-filename
delete-file
delete-file-no-errors
directory-file-names
+ error:not-mime-token
+ error:not-mime-token-string
+ error:not-mime-type
+ error:not-mime-type-string
file-access
file-directory?
file-eq?
file-writeable?
guarantee-init-file-directory
guarantee-init-file-specifier
+ guarantee-mime-token
+ guarantee-mime-token-string
+ guarantee-mime-type
+ guarantee-mime-type-string
hard-link-file
init-file-specifier?
make-directory
+ make-mime-type
+ mime-token-string?
+ mime-token?
+ mime-type->string
+ mime-type-string?
+ mime-type/subtype
+ mime-type/top-level
+ mime-type?
open-input-init-file
open-output-init-file
+ pathname-mime-type
+ pathname-type->mime-type
rename-file
- soft-link-file))
+ soft-link-file
+ string->mime-type)
+ (initialization (initialize-package!)))
(define-package (runtime symbol)
(files "symbol")
pathname-device
pathname-directory
pathname-host
- pathname-mime-type
pathname-name
pathname-new-device
pathname-new-directory
#| -*-Scheme-*-
-$Id: sfile.scm,v 14.35 2003/09/05 20:51:22 cph Exp $
+$Id: sfile.scm,v 14.36 2004/10/28 19:38:23 cph Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1999,2001,2003 Massachusetts Institute of Technology
(define (open-output-init-file specifier #!optional append?)
(let ((pathname (init-file-specifier->pathname specifier)))
(guarantee-init-file-directory pathname)
- (open-output-file pathname (if (default-object? append?) #f append?))))
\ No newline at end of file
+ (open-output-file pathname (if (default-object? append?) #f append?))))
+\f
+;;;; MIME types
+
+(define-record-type <mime-type>
+ (%make-mime-type top-level subtype)
+ mime-type?
+ (top-level mime-type/top-level)
+ (subtype mime-type/subtype))
+
+(set-record-type-unparser-method! <mime-type>
+ (standard-unparser-method 'MIME-TYPE
+ (lambda (mime-type port)
+ (write-char #\space port)
+ (write-string (mime-type->string mime-type) port))))
+
+(define (make-mime-type top-level subtype)
+ (guarantee-mime-token top-level 'MAKE-MIME-TYPE)
+ (guarantee-mime-token subtype 'MAKE-MIME-TYPE)
+ (%make-mime-type top-level subtype))
+
+(define (mime-type->string mime-type)
+ (guarantee-mime-type mime-type 'MIME-TYPE->STRING)
+ (string-append (symbol-name (mime-type/top-level mime-type))
+ "/"
+ (symbol-name (mime-type/subtype mime-type))))
+
+(define (string->mime-type string)
+ (guarantee-mime-type-string string 'STRING->MIME-TYPE)
+ (let ((slash (string-find-next-char string #\/)))
+ (%make-mime-type (intern (string-head string slash))
+ (intern (string-tail string (fix:+ slash 1))))))
+
+(define (mime-type-string? object)
+ (and (string? object)
+ (string-is-mime-type? object)))
+
+(define (string-is-mime-type? string)
+ (let ((end (string-length string)))
+ (let ((i (check-mime-token-syntax string 0 end)))
+ (and (fix:> i 0)
+ (fix:< i end)
+ (char=? (string-ref string i) #\/)
+ (fix:< (fix:+ i 1) end)
+ (fix:= end (check-mime-token-syntax string (fix:+ i 1) end))
+ i))))
+
+(define (mime-token? object)
+ (and (interned-symbol? object)
+ (string-is-mime-token? (symbol-name object))))
+
+(define (mime-token-string? object)
+ (and (string? object)
+ (string-is-mime-token? object)))
+
+(define (string-is-mime-token? string)
+ (let ((end (string-length string)))
+ (fix:= end (check-mime-token-syntax string 0 end))))
+
+(define (check-mime-token-syntax string start end)
+ (let loop ((i start))
+ (if (fix:< i end)
+ (if (char-set-member? char-set:mime-token (string-ref string i))
+ (loop (fix:+ i 1))
+ i)
+ end)))
+
+(define char-set:mime-token)
+(define (initialize-package!)
+ (set! char-set:mime-token
+ (char-set-difference (ascii-range->char-set #x21 #x7F)
+ (string->char-set "()<>@,;:\\\"/[]?=")))
+ unspecific)
+\f
+(define (pathname-mime-type pathname)
+ (pathname-type->mime-type (pathname-type pathname)))
+
+(define (pathname-type->mime-type type)
+ (and (string? type)
+ (let ((string (os/suffix-mime-type type)))
+ (and string
+ (string->mime-type string)))))
+
+(define-syntax define-guarantee
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form))
+ (let ((root (cadr form))
+ (desc (close-syntax (caddr form) environment)))
+ (let ((p-name (symbol root '?))
+ (g-name (symbol 'guarantee- root))
+ (e-name (symbol 'error:not- root)))
+ `(BEGIN
+ (DEFINE (,g-name OBJECT CALLER)
+ (IF (NOT (,(close-syntax p-name environment) OBJECT))
+ (,(close-syntax e-name environment) OBJECT CALLER)))
+ (DEFINE (,e-name OBJECT CALLER)
+ (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,desc CALLER)))))
+ (ill-formed-syntax form)))))
+
+(define-guarantee mime-type "MIME type")
+(define-guarantee mime-type-string "MIME type string")
+(define-guarantee mime-token "MIME token")
+(define-guarantee mime-token-string "MIME token string")
\ No newline at end of file
projects / mit-scheme.git / commitdiff