From: Chris Hanson Date: Thu, 9 Mar 2006 19:18:34 +0000 (+0000) Subject: Implement support for parsing #[...] syntax. Currently this works for X-Git-Tag: 20090517-FFI~1067 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=683a09fd41f89c07dae10795f7ae38e3fc424688;p=mit-scheme.git Implement support for parsing #[...] syntax. Currently this works for pathnames and URIs. --- diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm index e21fdd668..9d85c72ff 100644 --- a/v7/src/runtime/boot.scm +++ b/v7/src/runtime/boot.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -37,6 +37,20 @@ USA. (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)) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 9d8ad6f08..18f6e38c0 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.101 2005/08/05 20:04:19 cph Exp $ +$Id: make.scm,v 14.102 2006/03/09 19:18:30 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology @@ -464,6 +464,7 @@ USA. ;; Syntax (RUNTIME NUMBER-PARSER) (RUNTIME PARSER) + ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD! #t) (RUNTIME UNPARSER) (RUNTIME UNSYNTAXER) (RUNTIME PRETTY-PRINTER) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index 2609bbf56..eebc23895 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -168,6 +168,7 @@ USA. (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) @@ -333,26 +334,6 @@ USA. (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) @@ -373,6 +354,60 @@ USA. (define close-parenthesis (list 'CLOSE-PARENTHESIS)) (define close-bracket (list 'CLOSE-BRACKET)) +(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)))) + (define (handler:quote port db ctx char) ctx char (list 'QUOTE (read-object port db))) @@ -482,7 +517,7 @@ USA. char) port*) (loop))))))))) - + (define (handler:named-constant port db ctx char1 char2) ctx char1 char2 (let ((name (parse-atom/no-quoting port db '()))) @@ -502,20 +537,6 @@ USA. (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)) - -(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 diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 28152fe1e..3eac3b737 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -115,12 +115,13 @@ these rules: (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)) @@ -702,4 +703,7 @@ these rules: (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 diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index cf9233c0b..ff492832d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.579 2006/03/07 20:40:24 cph Exp $ +$Id: runtime.pkg,v 14.580 2006/03/09 19:18:33 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -158,6 +158,8 @@ USA. interrupt-mask/timer-ok object-constant? object-pure? + simple-parser-method + simple-unparser-method standard-unparser-method unparser-method? unparser/standard-method @@ -2532,6 +2534,7 @@ USA. *parser-canonicalize-symbols?* *parser-radix* *parser-table* + define-bracketed-object-parser-method parse-object parse-objects system-global-parser-table) diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index bc6aec63b..b4be22b20 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -41,10 +41,15 @@ USA. (string %uri-string)) (set-record-type-unparser-method! - (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))) @@ -57,9 +62,7 @@ USA. (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))) @@ -938,7 +941,7 @@ USA. (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)) ;;;; Testing