From ba5cdcf6fb1596b06cabbb6c3c4c906d4fbb99e8 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Wed, 12 Nov 2003 11:11:55 +0000 Subject: [PATCH] Removed infix directory. It has a non-free copyright and will therefore be removed from S48 as well. --- scheme/infix/packages.scm | 29 ---- scheme/infix/pratt.scm | 308 ---------------------------------- scheme/infix/sgol-runtime.scm | 11 -- scheme/infix/sgol.scm | 213 ----------------------- scheme/infix/tokenize.scm | 154 ----------------- 5 files changed, 715 deletions(-) delete mode 100644 scheme/infix/packages.scm delete mode 100644 scheme/infix/pratt.scm delete mode 100644 scheme/infix/sgol-runtime.scm delete mode 100644 scheme/infix/sgol.scm delete mode 100644 scheme/infix/tokenize.scm diff --git a/scheme/infix/packages.scm b/scheme/infix/packages.scm deleted file mode 100644 index c843e60..0000000 --- a/scheme/infix/packages.scm +++ /dev/null @@ -1,29 +0,0 @@ -; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING. - -; Infix stuff - -(define-structure tokenizer (export make-tokenizer-table - set-up-usual-tokenization! - set-char-tokenization! - tokenize) - (open scheme records signals defpackage ascii) - (access primitives) - (files tokenize)) - -(define-structure pratt (export toplevel-parse - parse - make-operator - make-lexer-table set-char-tokenization! - lexer-ttab define-keyword define-punctuation - prsmatch comma-operator delim-error erb-error - if-operator - then-operator else-operator parse-prefix - parse-nary parse-infix - parse-matchfix end-of-input-operator - port->stream) - (open scheme records signals tokenizer tables) - (files pratt)) - -(define-structure sgol (export sgol-read sgol-repl) - (open scheme signals pratt) - (files sgol)) diff --git a/scheme/infix/pratt.scm b/scheme/infix/pratt.scm deleted file mode 100644 index a50a423..0000000 --- a/scheme/infix/pratt.scm +++ /dev/null @@ -1,308 +0,0 @@ -; -*- Mode: Scheme; -*- -; -; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM -; Siod may be obtained by anonymous FTP to world.std.com:pub/gjc. -; -; * COPYRIGHT (c) 1988-1994 BY * -; * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * -; * ALL RIGHTS RESERVED * -; -;Permission to use, copy, modify, distribute and sell this software -;and its documentation for any purpose and without fee is hereby -;granted, provided that the above copyright notice appear in all copies -;and that both that copyright notice and this permission notice appear -;in supporting documentation, and that the name of Paradigm Associates -;Inc not be used in advertising or publicity pertaining to distribution -;of the software without specific, written prior permission. -; -;PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL -;PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, -;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -;SOFTWARE. -; -; Based on a theory of parsing presented in: -; -; Pratt, Vaughan R., ``Top Down Operator Precedence,'' -; ACM Symposium on Principles of Programming Languages -; Boston, MA; October, 1973. -; - -; The following terms may be useful in deciphering this code: - -; NUD -- NUll left Denotation (op has nothing to its left (prefix)) -; LED -- LEft Denotation (op has something to left (postfix or infix)) - -; LBP -- Left Binding Power (the stickiness to the left) -; RBP -- Right Binding Power (the stickiness to the right) -; - -; Mods for Scheme 48 by J Rees 6-14-90 - -; From: -; -; Now a neat thing that CGOL had was a way of packaging and scoping -; different parsing contexts. The maclisp implementation was simple, -; instead of just NUD and LED and other properties there was a list -; of property indicators. And a lookup operation. -; -; One use of the local-context thing, in parsing the C language -; you can use a different binding-power for ":" depending on -; what kind of statement you are parsing, a general statement -; context where ":" means a label, a "switch" or the "if for value -; " construct of (a > b) > c : d; - - -(define (peek-token stream) - (stream 'peek #f)) - -(define (read-token stream) - (stream 'get #f)) - -(define (toplevel-parse stream) - (if (eq? end-of-input-operator (peek-token stream)) - (read-token stream) - (parse -1 stream))) - - -; A token is either an operator or atomic (number, identifier, etc.) - -(define operator-type - (make-record-type 'operator - '(name lbp rbp nud led))) - -(define make-operator - (let () - (define make - (record-constructor operator-type '(name lbp rbp nud led))) - (define (make-operator name lbp rbp nud led) - (make name - (or lbp default-lbp) - (or rbp default-rbp) - (or nud default-nud) - (or led default-led))) - make-operator)) - -(define operator? (record-predicate operator-type)) - -(define operator-name (record-accessor operator-type 'name)) -(define operator-nud (record-accessor operator-type 'nud)) -(define operator-led (record-accessor operator-type 'led)) -(define operator-lbp (record-accessor operator-type 'lbp)) -(define operator-rbp (record-accessor operator-type 'rbp)) - -(define (default-nud operator stream) - (if (eq? (operator-led operator) default-led) - operator - (error 'not-a-prefix-operator operator))) - -(define (nudcall token stream) - (if (operator? token) - ((operator-nud token) token stream) - token)) - -(define default-led #f) - -;+++ To do: fix this to make juxtaposition work (f x+y) - -(define (ledcall token left stream) - ((or (and (operator? token) - (operator-led token)) - (error 'not-an-infix-operator token)) - token - left - stream)) - -(define default-lbp 200) - -(define (lbp token) - (if (operator? token) - (operator-lbp token) - default-lbp)) - -(define default-rbp 200) - -(define (rbp token) - (if (operator? token) - (operator-rbp token) - default-rbp)) - -(define-record-discloser operator-type - (lambda (obj) - (list 'operator (operator-name obj)))) - -; Mumble - -(define (delim-error token stream) - (error 'invalid-use-of-delimiter token)) - -(define (erb-error token left stream) - (error 'too-many-right-parentheses token)) - -(define (premterm-err token stream) - (error 'premature-termination-of-input token)) - -; Parse - -(define *parse-debug* #f) - -(define (parse rbp-level stream) - (if *parse-debug* (print `(parse ,rbp-level))) - (let parse-loop ((translation (nudcall (read-token stream) stream))) - (if (< rbp-level (lbp (peek-token stream))) - (parse-loop (ledcall (read-token stream) translation stream)) - (begin (if *parse-debug* (print translation)) - translation)))) - -(define (print s) (write s) (newline)) - -(define (parse-prefix operator stream) - (list (operator-name operator) - (parse (rbp operator) stream))) - -(define (parse-infix operator left stream) - (list (operator-name operator) - left - (parse (rbp operator) stream))) - -(define (parse-nary operator left stream) - (cons (operator-name operator) (cons left (prsnary operator stream)))) - -(define (prsnary operator stream) - (define (loop l) - (if (eq? operator (peek-token stream)) - (begin (read-token stream) - (loop (cons (parse (rbp operator) stream) l))) - (reverse l))) - (loop (list (parse (rbp operator) stream)))) - -; Parenthesis matching, with internal commas. -; Kind of a kludge if you ask me. - -(define (parse-matchfix operator stream) ; |x| - (cons (operator-name operator) - (prsmatch operator stream))) - -(define (prsmatch close-op stream) - (if (eq? (peek-token stream) close-op) - (begin (read-token stream) - '()) - (let loop ((l (list (parse 10 stream)))) - (if (eq? (peek-token stream) close-op) - (begin (read-token stream) - (reverse l)) - (if (eq? (peek-token stream) comma-operator) - (begin (read-token stream) - (loop (cons (parse 10 stream) l))) - (error 'comma-or-match-not-found (read-token stream))))))) - -(define comma-operator (make-operator 'comma 10 #f delim-error #f)) - -; if A then B [else C] - -(define (if-nud token stream) - (let* ((pred (parse (rbp token) stream)) - (then (if (eq? (peek-token stream) then-operator) - (parse (rbp (read-token stream)) stream) - (error 'missing-then pred)))) - (if (eq? (peek-token stream) else-operator) - `(if ,pred ,then ,(parse (rbp (read-token stream)) stream)) - `(if ,pred ,then)))) - -(define if-operator (make-operator 'if #f 45 if-nud #f)) -(define then-operator (make-operator 'then 5 25 delim-error #f)) -(define else-operator (make-operator 'else 5 25 delim-error #f)) - -; Lexer support: - -(define lexer-type - (make-record-type 'lexer '(ttab punctab keytab))) - -(define lexer-ttab (record-accessor lexer-type 'ttab)) -(define lexer-punctab (record-accessor lexer-type 'punctab)) -(define lexer-keytab (record-accessor lexer-type 'keytab)) - -(define make-lexer-table - (let ((make (record-constructor lexer-type '(ttab punctab keytab)))) - (lambda () - (let ((ttab (make-tokenizer-table))) - (set-up-usual-tokenization! ttab) - (make ttab (make-table) (make-table)))))) - -(define (lex ltab port) - (let ((thing (tokenize (lexer-ttab ltab) port))) - (cond ((eof-object? thing) - end-of-input-operator) - ((symbol? thing) - (or (table-ref (lexer-keytab ltab) thing) - thing)) - (else thing)))) - -; Keywords - -(define (define-keyword ltab name op) - (table-set! (lexer-keytab ltab) name op)) - -; Punctuation - -; lexnode = (* operator (table-of char (+ lexnode #f))) -- discrimination tree - -(define (define-punctuation ltab string op) - (let ((end (- (string-length string) 1))) - (let loop ((i 0) - (table (lexer-punctab ltab))) - (let* ((c (string-ref string i)) - (lexnode - (or (table-ref table c) - (let ((lexnode - (cons (error-operator (substring string 0 (+ i 1))) - (make-table)))) - (table-set! table c lexnode) - (if (= i 0) - (set-char-tokenization! (lexer-ttab ltab) - c - (operator-reader lexnode) - #t)) - lexnode)))) - (if (>= i end) - (set-car! lexnode op) - (loop (+ i 1) (cdr lexnode))))))) - -(define (operator-reader lexnode) - (lambda (c port) - (let loop ((lexnode lexnode)) - (let ((nextc (peek-char port))) - (let ((nextnode (table-ref (cdr lexnode) nextc))) - (if nextnode - (begin (read-char port) - (loop nextnode)) - (car lexnode))))))) - -(define (error-operator string) - (make-operator 'invalid-operator #f #f - (lambda rest (error "invalid operator" string)) - #f)) - -; Mumble - -(define end-of-input-operator - (make-operator "end of input" -1 #f premterm-err #f)) - -(define (port->stream port ltab) - (define (really-get) - (lex ltab port)) - (define peeked? #f) - (define peek #f) - (define (stream op arg) - (case op - ((get) (if peeked? - (begin (set! peeked? #f) peek) - (really-get))) - ((peek) (if peeked? - peek - (begin (set! peeked? #t) - (set! peek (really-get)) - peek))))) - stream) diff --git a/scheme/infix/sgol-runtime.scm b/scheme/infix/sgol-runtime.scm deleted file mode 100644 index 1b99273..0000000 --- a/scheme/infix/sgol-runtime.scm +++ /dev/null @@ -1,11 +0,0 @@ -; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING. - - -(define (%unspecific) - (if #f #f)) - -(define (!= x y) - (not (= x y))) - -(define (%tuple . rest) - (list->vector (cons 'tuple rest))) diff --git a/scheme/infix/sgol.scm b/scheme/infix/sgol.scm deleted file mode 100644 index e47c1bd..0000000 --- a/scheme/infix/sgol.scm +++ /dev/null @@ -1,213 +0,0 @@ -; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING. - - -; Lexer for Infix Scheme (JAR's obscure syntax) -; Bears no relation to Pratt's CGOL - -; To do: add ML-ish binding constructs. - -; (sgol-read) reads an expression -; -; semicolon terminates input -; comment character is # (comment goes to end of line) -; -; f(x, y) reads as (f x y) -; -; if x then y else z reads as (if x y z) -; x and y, x or y, not x do the obvious thing -; -; x + y reads as (+ x y) - similarly for - * / = < > <= >= -; -; x::y reads as (cons x y) - ML's syntax -; x++y reads as (append x y) - whose syntax? Haskell's? -; [] reads as '() -; [a, b, ...] reads as (list a b ...) -; -; () reads as the-unit -; (x, y, ...) reads as (tuple x y ...) -; -; a[i] reads as (vector-ref a i) -; a[i, j, ...] reads as (array-ref a i j ...) -; -; x := y reads as (set! x y) -; car(x) := y reads as (set-car! x y) - similarly for cdr -; x[y] := z reads as (vector-set! x y z) - similarly for array-ref -; -; 'foo' tries to read as 'foo but usually loses - - -(define sgol-lexer-table (make-lexer-table)) - -(set-char-tokenization! (lexer-ttab sgol-lexer-table) - #\# - (lambda (c port) - c ;ignored - (gobble-line port) - (read port)) - #t) - -(define (gobble-line port) - (let loop () - (let ((c (read-char port))) - (cond ((eof-object? c) c) - ((char=? c #\newline) #f) - (else (loop)))))) - -; - -(define (define-sgol-keyword name op) - (define-keyword sgol-lexer-table name op)) - -(define (define-sgol-punctuation string op) - (define-punctuation sgol-lexer-table string op)) - -; Arguments to make-operator are: name lbp rbp nud led - -(define (open-paren-nud token stream) - (let ((right (prsmatch close-paren-operator stream))) - (if (null? right) - 'the-unit ; () - (if (null? (cdr right)) - (car right) ; (x) - (cons 'tuple right))))) ; (x, y, ..., z) - -; f(x, y) reads as (f x y) -; f((x, y)) reads as (f (tuple x y)) - -(define (open-paren-led token left stream) - (cons left (prsmatch close-paren-operator stream))) - -(define-sgol-punctuation "(" - (make-operator 'open-paren 200 #f open-paren-nud open-paren-led)) - -(define-sgol-punctuation "," comma-operator) - -(define close-paren-operator - (make-operator 'close-paren 5 #f delim-error erb-error)) -(define-sgol-punctuation ")" close-paren-operator) - -; Boolean operators - -(define-sgol-keyword 'true '#t) -(define-sgol-keyword 'false '#f) - -(define-sgol-keyword 'if if-operator) -(define-sgol-keyword 'then then-operator) -(define-sgol-keyword 'else else-operator) - -(define-sgol-keyword 'not (make-operator 'not 70 70 parse-prefix #f)) -(define-sgol-keyword 'and (make-operator 'and 65 #f #f parse-nary)) -(define-sgol-keyword 'or (make-operator 'or 60 #f #f parse-nary)) - -; Lists - -(define (open-bracket-nud token stream) - (let ((elements (prsmatch close-bracket-operator stream))) - (if (null? elements) - `'() - `(list ,@elements)))) - -(define (open-bracket-led token left stream) - (let ((subscripts (prsmatch close-bracket-operator stream))) - (if (and (not (null? subscripts)) - (null? (cdr subscripts))) - `(vector-ref ,left ,@subscripts) - `(array-ref ,left ,@subscripts)))) - -(define-sgol-punctuation "[" - (make-operator 'open-bracket 200 #f open-bracket-nud open-bracket-led)) - -(define close-bracket-operator - (make-operator 'close-bracket 5 #f delim-error erb-error)) -(define-sgol-punctuation "]" close-bracket-operator) - -(define-sgol-punctuation "::" - (make-operator 'cons 75 74 #f parse-infix)) - -(define-sgol-punctuation "++" - (make-operator 'append 75 74 #f parse-nary)) - -; Quotation - -(define-sgol-punctuation "'" - (make-operator 'quote 5 #f parse-matchfix #f)) ;This isn't right - -; Arithmetic - -(define-sgol-punctuation "+" - (make-operator '+ 100 100 parse-prefix parse-infix)) - -(define-sgol-punctuation "-" - (make-operator '- 100 100 parse-prefix parse-infix)) - -(define-sgol-punctuation "*" - (make-operator '* 120 120 #f parse-infix)) ;should be parse-nary - -(define-sgol-punctuation "/" - (make-operator '/ 120 120 #f parse-infix)) - -(define-sgol-punctuation "=" - (make-operator '= 80 80 #f parse-infix)) - -(define-sgol-punctuation ">" - (make-operator '> 80 80 #f parse-infix)) - -(define-sgol-punctuation "<" - (make-operator '< 80 80 #f parse-infix)) - -(define-sgol-punctuation ">=" - (make-operator '>= 80 80 #f parse-infix)) - -(define-sgol-punctuation "<=" - (make-operator '<= 80 80 #f parse-infix)) - -(define-sgol-punctuation "!=" - (make-operator '!= 80 80 #f parse-infix)) - -; Side effects - -(define (:=-led token left stream) - (let* ((form (parse-infix token left stream)) - (lhs (cadr form)) - (rhs (caddr form))) - (if (pair? lhs) - (case (car lhs) - ((car) `(set-car! ,@(cdr lhs) ,rhs)) - ((cdr) `(set-cdr! ,@(cdr lhs) ,rhs)) - ((vector-ref) `(vector-set! ,@(cdr lhs) ,rhs)) - ((array-ref) `(array-set! ,@(cdr lhs) ,rhs)) - (else (error "invalid LHS for :=" form))) - form))) - -(define-sgol-punctuation ":=" - (make-operator 'set! 70 #f #f :=-led)) - -; End of input... - -(define-sgol-punctuation ";" end-of-input-operator) - -; Read using Pratt parser with SGOL tokenizer table - -(define (sgol-read . port-option) - (toplevel-parse (port->stream (if (null? port-option) - (current-input-port) - (car port-option)) - sgol-lexer-table))) - -; Read/print loop - -(define (rpl) - (let ((thing (sgol-read))) - (if (not (eq? thing end-of-input-operator)) - (begin (write thing) - (newline) - (rpl))))) - -; Read/eval/print loop - -(define (rpl) - (let ((thing (sgol-read))) - (if (not (eq? thing end-of-input-operator)) - (begin (write thing) - (newline) - (rpl))))) diff --git a/scheme/infix/tokenize.scm b/scheme/infix/tokenize.scm deleted file mode 100644 index 1756a6c..0000000 --- a/scheme/infix/tokenize.scm +++ /dev/null @@ -1,154 +0,0 @@ -; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- -; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING. - - -; A tokenizer. - -; Nonstandard things needed: -; record package -; char->ascii -; peek-char -; reverse-list->string -; error - -(define (reverse-list->string l n) - (list->string (reverse l))) - -; Tokenizer tables - -(define tokenizer-table-type - (make-record-type 'tokenizer-table - '(translation dispatch-vector terminating?-vector))) - -(define make-tokenizer-table - (let () - (define make - (record-constructor tokenizer-table-type - '(translation dispatch-vector terminating?-vector))) - (define (make-tokenizer-table) - (make (if (char=? (string-ref (symbol->string 't) 0) #\T) - char-upcase - char-downcase) - (make-vector 256 (lambda (c port) - (error "illegal character read" c))) - (make-vector 256 #t))) - make-tokenizer-table)) - -(define ttab-translation - (record-accessor tokenizer-table-type 'translation)) -(define ttab-dispatch-vector - (record-accessor tokenizer-table-type 'dispatch-vector)) -(define ttab-terminating?-vector - (record-accessor tokenizer-table-type 'terminating?-vector)) - -(define set-tokenizer-table-translator! - (record-modifier tokenizer-table-type 'translation)) - -(define (set-char-tokenization! ttab char reader term?) - (vector-set! (ttab-dispatch-vector ttab) (char->ascii char) reader) - (vector-set! (ttab-terminating?-vector ttab) (char->ascii char) term?)) - -; Main dispatch - -(define (tokenize ttab port) - (let ((c (read-char port))) - (if (eof-object? c) - c - ((vector-ref (ttab-dispatch-vector ttab) (char->ascii c)) - c port)))) - -; Atoms (symbols and numbers) - -(define (scan-atom c ttab port) - (let ((translate (ttab-translation ttab))) - (let loop ((l (list (translate c))) (n 1)) - (let ((c (peek-char port))) - (cond ((or (eof-object? c) - (vector-ref (ttab-terminating?-vector ttab) - (char->ascii c))) - (reverse-list->string l n)) - (else - (loop (cons (translate (read-char port)) l) - (+ n 1)))))))) - -; Allow ->foo, -v-, etc. - -(define (parse-atom string) - (let ((c (string-ref string 0))) - (cond ((char=? c #\+) - (parse-possible-number string)) - ((char=? c #\-) - (parse-possible-number string)) - ((char=? c #\.) - (parse-possible-number string)) - (else - (if (char-numeric? c) - (parse-number string) - (string->symbol string)))))) - -; First char is + - . - -(define (parse-possible-number string) - (if (and (> (string-length string) 1) - (char-numeric? (string-ref string 1))) - (parse-number string) - (string->symbol string))) - -(define (parse-number string) - (or (string->number string 'e 'd) - (error "unsupported number syntax" string))) - - -; Usual stuff (what you'd expect to be common to Scheme and ML syntax) - -(define (set-up-usual-tokenization! ttab) - - (define (tokenize-whitespace c port) c ;ignored - (tokenize ttab port)) - - (define (tokenize-constituent c port) - (parse-atom (scan-atom c ttab port))) - - (for-each (lambda (c) - (set-char-tokenization! ttab (ascii->char c) - tokenize-whitespace #t)) - ascii-whitespaces) - - (for-each (lambda (c) - (set-char-tokenization! ttab c tokenize-constituent #f)) - (string->list - (string-append ".0123456789" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "abcdefghijklmnopqrstuvwxyz"))) - - (set-char-tokenization! ttab #\" tokenize-string #t) - - ) - -(define (make-constituent! c ttab) - (set-char-tokenization! ttab c - (lambda (c port) - (parse-atom (scan-atom c ttab port))) - #f)) - -(define (tokenize-string c port) c ;ignored - (let loop ((l '()) (i 0)) - (let ((c (read-char port))) - (cond ((eof-object? c) - (error "end of file within a string")) - ((char=? c #\\) - (let ((c (read-char port))) - (if (or (char=? c #\\) (char=? c #\")) - (loop (cons c l) (+ i 1)) - (error "invalid escaped character in string" c)))) - ((char=? c #\") (reverse-list->string l i)) - (else (loop (cons c l) (+ i 1))))))) - -; Auxiliary for parse-atom and tokenize-string - -;(define (reverse-list->string l n) ;In microcode? -; (let ((s (make-string n))) -; (do ((l l (cdr l)) -; (i (- n 1) (- i 1))) -; ((< i 0) s) -; (string-set! s i (car l)))))