#| -*-Scheme-*-
-$Id: boot.scm,v 14.21 2005/07/31 02:54:29 cph Exp $
+$Id: boot.scm,v 14.22 2006/03/09 19:18:29 cph Exp $
Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
-Copyright 1993,1996,2001,2004,2005 Massachusetts Institute of Technology
+Copyright 1993,1996,2001,2004,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(lambda (port)
(unparser object port)))))))
+(define (simple-unparser-method name method)
+ (standard-unparser-method name
+ (lambda (object port)
+ (for-each (lambda (object)
+ (write-char #\space port)
+ (write object port))
+ (method object)))))
+
+(define (simple-parser-method procedure)
+ (lambda (objects lose)
+ (or (and (pair? (cdr objects))
+ (procedure (cddr objects)))
+ (lose))))
+
(define (unparser/standard-method name #!optional unparser)
(make-method name
(and (not (default-object? unparser))
#| -*-Scheme-*-
-$Id: parse.scm,v 14.60 2005/05/30 18:48:43 cph Exp $
+$Id: parse.scm,v 14.61 2006/03/09 19:18:31 cph Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology
(set! char-set/number-leaders number-leaders))
(set! *parser-table* system-global-parser-table)
(set! runtime-parser-table system-global-parser-table)
+ (set! hashed-object-interns (make-strong-eq-hash-table))
(initialize-condition-types!))
(define-integrable (atom-delimiter? char)
(list->vector (reverse! objects))
(loop (cons object objects))))))
-(define (handler:hashed-object port db ctx char1 char2)
- ctx char1 char2
- (let loop ((objects '()))
- (let ((object (read-in-context port db 'CLOSE-BRACKET-OK)))
- (if (eq? object close-bracket)
- (let ((objects (reverse! objects)))
- (if (and (pair? objects)
- (pair? (cdr objects)))
- (parse-unhash (cadr objects))
- (error:illegal-hashed-object objects)))
- (loop (cons object objects))))))
-
-(define (parse-unhash object)
- (if (not (exact-nonnegative-integer? object))
- (error:illegal-unhash object))
- (if (eq? object 0)
- #f
- (or (object-unhash object)
- (error:undefined-hash object))))
-
(define (handler:close-parenthesis port db ctx char)
db
(cond ((eq? ctx 'CLOSE-PAREN-OK)
(define close-parenthesis (list 'CLOSE-PARENTHESIS))
(define close-bracket (list 'CLOSE-BRACKET))
\f
+(define (handler:hashed-object port db ctx char1 char2)
+ ctx char1 char2
+ (let loop ((objects '()))
+ (let ((object (read-in-context port db 'CLOSE-BRACKET-OK)))
+ (if (eq? object close-bracket)
+ (let* ((objects (reverse! objects))
+ (lose (lambda () (error:illegal-hashed-object objects))))
+ (let ((method
+ (and (pair? objects)
+ (interned-symbol? (car objects))
+ (hash-table/get hashed-object-interns
+ (car objects)
+ (lambda (objects lose)
+ (if (pair? (cdr objects))
+ (parse-unhash (cadr objects))
+ (lose)))))))
+ (if method
+ (bind-condition-handler (list condition-type:error)
+ (lambda (condition) condition (lose))
+ (lambda ()
+ (method objects lose)))
+ (lose))))
+ (loop (cons object objects))))))
+
+(define (define-bracketed-object-parser-method name method)
+ (guarantee-interned-symbol name 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD)
+ (guarantee-procedure-of-arity method 2
+ 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD)
+ (hash-table/put! hashed-object-interns name method))
+
+(define hashed-object-interns)
+
+(define (handler:unhash port db ctx char1 char2)
+ ctx char1 char2
+ (let ((object (parse-unhash (parse-number port db '()))))
+ ;; This may seem a little random, because #@N doesn't just
+ ;; return an object. However, the motivation for this piece of
+ ;; syntax is convenience -- and 99.99% of the time the result of
+ ;; this syntax will be evaluated, and the user will expect the
+ ;; result of the evaluation to be the object she was referring
+ ;; to. If the quotation isn't there, the user just gets
+ ;; confused.
+ (if (scode-constant? object)
+ object
+ (make-quotation object))))
+
+(define (parse-unhash object)
+ (if (not (exact-nonnegative-integer? object))
+ (error:illegal-unhash object))
+ (if (eq? object 0)
+ #f
+ (or (object-unhash object)
+ (error:undefined-hash object))))
+\f
(define (handler:quote port db ctx char)
ctx char
(list 'QUOTE (read-object port db)))
char)
port*)
(loop)))))))))
-
+\f
(define (handler:named-constant port db ctx char1 char2)
ctx char1 char2
(let ((name (parse-atom/no-quoting port db '())))
(define lambda-rest-tag (object-new-type (ucode-type constant) 4))
(define lambda-aux-tag (object-new-type (ucode-type constant) 8))
(define lambda-key-tag (object-new-type (ucode-type constant) 5))
-\f
-(define (handler:unhash port db ctx char1 char2)
- ctx char1 char2
- (let ((object (parse-unhash (parse-number port db '()))))
- ;; This may seem a little random, because #@N doesn't just
- ;; return an object. However, the motivation for this piece of
- ;; syntax is convenience -- and 99.99% of the time the result of
- ;; this syntax will be evaluated, and the user will expect the
- ;; result of the evaluation to be the object she was referring
- ;; to. If the quotation isn't there, the user just gets
- ;; confused.
- (if (scode-constant? object)
- object
- (make-quotation object))))
(define (handler:special-arg port db ctx char1 char2)
ctx char1
#| -*-Scheme-*-
-$Id: pathnm.scm,v 14.47 2006/03/09 05:29:28 cph Exp $
+$Id: pathnm.scm,v 14.48 2006/03/09 19:18:32 cph Exp $
Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
(type #f read-only #t)
(version #f read-only #t))
-(define (guarantee-pathname object caller)
- (if (not (pathname? object))
- (error:not-pathname object caller)))
+(define-guarantee pathname "pathname")
-(define (error:not-pathname object caller)
- (error:wrong-type-argument object "pathname" caller))
+(define pathname-parser-method
+ (simple-parser-method
+ (lambda (objects)
+ (and (pair? objects)
+ (->pathname (car objects))))))
(define (->pathname object)
(pathname-arg object #f '->PATHNAME))
(define (initialize-package!)
(reset-package!)
- (add-event-receiver! event:after-restore reset-package!))
\ No newline at end of file
+ (add-event-receiver! event:after-restore reset-package!))
+
+(define (initialize-parser-method!)
+ (define-bracketed-object-parser-method 'PATHNAME pathname-parser-method))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: url.scm,v 1.43 2006/03/06 04:42:59 cph Exp $
+$Id: url.scm,v 1.44 2006/03/09 19:18:34 cph Exp $
Copyright 2000,2001,2003,2004,2005,2006 Massachusetts Institute of Technology
(string %uri-string))
(set-record-type-unparser-method! <uri>
- (standard-unparser-method 'URI
- (lambda (uri port)
- (write-char #\space port)
- (write (uri->string uri) port))))
+ (simple-unparser-method 'URI
+ (lambda (uri)
+ (list (uri->string uri)))))
+
+(define uri-parser-method
+ (simple-parser-method
+ (lambda (objects)
+ (and (pair? objects)
+ (string->uri (car objects))))))
(define (make-uri scheme authority path query fragment)
(let ((path (if (equal? path '("")) '() path)))
(error:bad-range-argument path 'MAKE-URI))
(%make-uri scheme
authority
- (if scheme
- (remove-dot-segments path)
- path)
+ (if scheme (remove-dot-segments path) path)
query
fragment)))
(set! url:char-set:unescaped
(char-set-union url:char-set:unreserved
(string->char-set ";/?:@&=")))
- unspecific)
+ (define-bracketed-object-parser-method 'URI uri-parser-method))
\f
;;;; Testing
projects / mit-scheme.git / commitdiff