diff options
author | James LewisMoss <dres@debian.org> | 2001-07-27 23:45:29 -0400 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:29 -0800 |
commit | f559c149c83da84d0b1c285f0298c84aec564af9 (patch) | |
tree | f1c91bcb9bb5e6dad87b643127c3f878d80d89ee /struct.scm | |
parent | c394920caedf3dac1981bb6b10eeb47fd6e4bb21 (diff) | |
parent | 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff) | |
download | slib-f559c149c83da84d0b1c285f0298c84aec564af9.tar.gz slib-f559c149c83da84d0b1c285f0298c84aec564af9.zip |
Import Debian changes 2d2-1debian/2d2-1
slib (2d2-1) unstable; urgency=low
* New upstream version
* Revert back to free. Is now so.
slib (2d1-1) unstable; urgency=low
* New upstream version.
* Move to non-free. FSF pointed out license doesn't allow modified
versions to be distributed.
* Get a complete list of copyrights that apply to the source into
copyright file.
* Remove setup for guile 1.3.
* Remove postrm. Just calling install-info (lintian) Move install-info
call to prerm since doc-base doesn't do install-info.
slib (2c9-3) unstable; urgency=low
* Change info location to section "The Algorithmic Language Scheme" to
match up with where guile puts it's files.
* Postinst is running slibconfig now. (Closes: #75891)
slib (2c9-2) unstable; urgency=low
* Stop installing slibconfig (for guile).
* In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843
#75891).
slib (2c9-1) unstable; urgency=low
* New upstream (Closes: #74760)
* replace string-index with strsrch:string-index in http-cgi.scm.
* Add doc-base support (Closes: #31163)
Diffstat (limited to 'struct.scm')
-rw-r--r-- | struct.scm | 165 |
1 files changed, 0 insertions, 165 deletions
diff --git a/struct.scm b/struct.scm deleted file mode 100644 index 100d3ff..0000000 --- a/struct.scm +++ /dev/null @@ -1,165 +0,0 @@ -;;; "struct.scm": defmacros for RECORDS -;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson - -;;; Defmacros which implement RECORDS from the book: -;;; "Essentials of Programming Languages" by Daniel P. Friedman, -;;; M. Wand and C.T. Haynes. - -;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB. - -;;; Date: Sun, 20 Aug 1995 19:20:35 -0500 -;;; From: Gary Leavens <leavens@cs.iastate.edu> -;;; I thought you might want to know that, for using the file -;;; struct.scm with the EOPL book, one has to make 2 corrections. To -;;; correct it, there are two places where "-" has to be replaced by -;;; "->" as in the code below. - -(require 'common-list-functions) - -(defmacro define-record args - (check-define-record-syntax args - (lambda (name make-name name? field-accessors field-setters) - (letrec - ((make-fields - (lambda (field-accessors i) - (if (null? field-accessors) - '() - (cons - `(define ,(car field-accessors) - (lambda (obj) - (if (,name? obj) - (vector-ref obj ,i) - (slib:error ',(car field-accessors) - ": bad record" obj)))) - (make-fields (cdr field-accessors) (+ i 1)))))) - (make-setters - (lambda (field-accessors i) - (if (null? field-accessors) - '() - (cons - `(define ,(car field-accessors) - (lambda (obj val) - (if (,name? obj) - (vector-set! obj ,i val) - (slib:error ',(car field-accessors) - ": bad record" obj)))) - (make-setters (cdr field-accessors) (+ i 1))))))) - `(begin - ,@(make-fields field-accessors 1) - ,@(make-setters field-setters 1) - (define ,name? - (lambda (obj) - (and (vector? obj) - (= (vector-length obj) ,(+ 1 (length field-accessors))) - (eq? (vector-ref obj 0) ',name)))) - (define ,make-name - (lambda ,field-accessors - (vector ',name ,@field-accessors)))))))) - -(defmacro variant-case args - (check-variant-case-syntax args - (lambda (exp clauses) - (let ((var (gentemp))) - (let - ((make-clause - (lambda (clause) - (if (eq? (car clause) 'else) - `(#t ,@(cdr clause)) - `((,(car clause) ,var) - (let ,(map (lambda (field) - `(,(car field) (,(cdr field) ,var))) - (cadr clause)) - ,@(cddr clause))))))) - `(let ((,var ,exp)) - (cond ,@(map make-clause clauses)))))))) - -;;; syntax checkers - -;;; name make-name name? field-accessors - -(define check-define-record-syntax - (lambda (x k) - (cond - ((and (list? x) - (= (length x) 2) - (symbol? (car x)) - (list? (cadr x)) - (comlist:every symbol? (cadr x)) - (not (struct:duplicate-fields? (cadr x)))) - (let ((name (symbol->string (car x)))) - (let ((make-name (string->symbol - (string-append (symbol->string 'make-) name))) - (name? (string->symbol (string-append name "?"))) - (field-accessors - (map - (lambda (field) - (string->symbol - (string-append name "->" (symbol->string field)))) - (cadr x))) - (field-setters - (map - (lambda (field) - (string->symbol - (string-append - "set-" name "-" (symbol->string field) "!"))) - (cadr x)))) - (k (car x) make-name name? field-accessors field-setters)))) - (else (slib:error "define-record: invalid syntax" x))))) - -(define check-variant-case-syntax - (let - ((make-clause - (lambda (clause) - (if (eq? (car clause) 'else) - clause - (let ((name (symbol->string (car clause)))) - (let ((name? (string->symbol (string-append name "?"))) - (fields - (map - (lambda (field) - (cons field - (string->symbol - (string-append name "->" - (symbol->string field))))) - (cadr clause)))) - (cons name? (cons fields (cddr clause))))))))) - (lambda (args k) - (if (and (list? args) - (<= 2 (length args)) - (struct:clauses? (cdr args))) - (k (car args) (map make-clause (cdr args))) - (slib:error "variant-case: invalid syntax" args))))) - -(define struct:duplicate-fields? - (lambda (fields) - (cond - ((null? fields) #f) - ((memq (car fields) (cdr fields)) #t) - (else (struct:duplicate-fields? (cdr fields)))))) - -(define struct:clauses? - (let - ((clause? - (lambda (clause) - (and (list? clause) - (not (null? clause)) - (cond - ((eq? (car clause) 'else) - (not (null? (cdr clause)))) - (else (and (symbol? (car clause)) - (not (null? (cdr clause))) - (list? (cadr clause)) - (comlist:every symbol? (cadr clause)) - (not (struct:duplicate-fields? (cadr clause))) - (not (null? (cddr clause)))))))))) - (letrec - ((struct:duplicate-tags? - (lambda (tags) - (cond - ((null? tags) #f) - ((eq? (car tags) 'else) (not (null? (cdr tags)))) - ((memq (car tags) (cdr tags)) #t) - (else (struct:duplicate-tags? (cdr tags))))))) - (lambda (clauses) - (and (comlist:every clause? clauses) - (not (struct:duplicate-tags? (map car clauses)))))))) |