diff --git a/AUTHORS b/AUTHORS index 7a628846..ec2043d6 100644 --- a/AUTHORS +++ b/AUTHORS @@ -2,11 +2,6 @@ Jan Nieuwenhuizen Main author All files except the files listed below -Based on Scheme48's scheme/alt -module/mes/record.mes -module/mes/syntax.scm -module/srfi/srfi-9.scm - Based on Guile ECMAScript module/language/c/lexer.mes diff --git a/make.scm b/make.scm index b39cb12d..af2b0843 100755 --- a/make.scm +++ b/make.scm @@ -565,8 +565,6 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "module/mes/quasisyntax.mes" "module/mes/quasisyntax.scm" "module/mes/read-0.mes" - "module/mes/record-0.mes" - "module/mes/record.mes" "module/mes/repl.mes" "module/mes/scm.mes" "module/mes/syntax.mes" @@ -594,9 +592,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "module/srfi/srfi-26.mes" "module/srfi/srfi-26.scm" "module/srfi/srfi-43.mes" - "module/srfi/srfi-9-psyntax.mes" "module/srfi/srfi-9.mes" - "module/srfi/srfi-9.scm" "module/sxml/xpath.mes" "module/sxml/xpath.scm")) diff --git a/module/mes/record-0.mes b/module/mes/record-0.mes deleted file mode 100644 index 23a9d770..00000000 --- a/module/mes/record-0.mes +++ /dev/null @@ -1,38 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; record-0.mes mes-specific definitions needed for record.mes - -;;; Code: - -(define (unspecific) (if #f #f)) -(define make-record make-vector) -(define record-set! vector-set!) -(define record? vector?) -(define (record-type x) (vector-ref x 0)) -(define record-ref vector-ref) -(define (call-error message . rest) - (display "call-error:" (current-error-port)) - (display message (current-error-port)) - (display ":" (current-error-port)) - (display rest (current-error-port)) - (newline (current-error-port))) diff --git a/module/mes/record.mes b/module/mes/record.mes deleted file mode 100644 index ddc0249c..00000000 --- a/module/mes/record.mes +++ /dev/null @@ -1,258 +0,0 @@ -;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; record.mes is loaded after record-0.mes. It provides a -;;; nonstandard record type that SRFI-9 can be trivially implemented -;;; on. Adapted from scheme48-1.1/scheme/rts/record.scm - -;;; Code: - -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. - -;;; scheme48-1.1/COPYING - -;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees -;; All rights reserved. - -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions -;; are met: -;; 1. Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; 2. Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; 3. The name of the authors may not be used to endorse or promote products -;; derived from this software without specific prior written permission. - -;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;;; Records - -; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE -; or by a procedure returned by record-constructor. A record-type is a -; record that describes a type of record. At the end of the file we create -; a record type that describes record types. - -; We number the record types for debugging purposes. - -(define *record-type-uid* -1) - -; This is the record type that describes record types. It is set a the end -; of the file. Its first slot points to itself. - -(define *record-type* #f) - -; Make a record type from a name, used for printing and debugging, and -; a list of field names. -; -; The VM references both the record type and the resumer, so their offsets -; should not be changed. - -(define (make-record-type name field-names) - (set! *record-type-uid* (+ *record-type-uid* 1)) - (let ((r (make-record 7 (unspecific)))) - (record-set! r 0 *record-type*) - (record-set! r 1 default-record-resumer) - (record-set! r 2 *record-type-uid*) - (record-set! r 3 name) - (record-set! r 4 field-names) - (record-set! r 5 (length field-names)) - (record-set! r 6 (make-default-record-discloser name)) - r)) - -(define (record-type? obj) - (and (record? obj) - (eq? (record-type obj) *record-type*))) - -; The various fields in a record type. - -(define (record-type-resumer rt) (record-ref rt 1)) -(define (set-record-type-resumer! rt r) (record-set! rt 1 r)) -(define (record-type-uid rt) (record-ref rt 2)) -(define (record-type-name rt) (record-ref rt 3)) -(define (record-type-field-names rt) (record-ref rt 4)) -(define (record-type-number-of-fields rt) (record-ref rt 5)) -(define (record-type-discloser rt) (record-ref rt 6)) -(define (set-record-type-discloser! rt d) (record-set! rt 6 d)) - -; This is a hack; it is read by the script that makes c/scheme48.h. - -(define record-type-fields - '(resumer uid name field-names number-of-fields discloser)) - -;---------------- -; Given a record type and the name of a field, return the field's index. - -(define (record-field-index rt name) - (let loop ((names (record-type-field-names rt)) - (i 1)) - (cond ((null? names) - (error "unknown field" - (record-type-name rt) - name)) - ((eq? name (car names)) - i) - (else - (loop (cdr names) (+ i 1)))))) - -; Return procedure for contstruction records of type RT. NAMES is a list of -; field names which the constructor will take as arguments. Other fields are -; uninitialized. - -(define (record-constructor rt names) - (let ((indexes (map (lambda (name) - (record-field-index rt name)) - names)) - (size (+ 1 (record-type-number-of-fields rt)))) - (lambda args - (let ((r (make-record size (unspecific)))) - (record-set! r 0 rt) - (let loop ((is indexes) (as args)) - (if (null? as) - (if (null? is) - r - (error "too few arguments to record constructor" - rt names args)) - (if (null? is) - (error "too many arguments to record constructor" - rt names args) - (begin (record-set! r (car is) (car as)) - (loop (cdr is) (cdr as)))))))))) - -; Making accessors, modifiers, and predicates for record types. - -(define (record-accessor rt name) - (let ((index (record-field-index rt name)) - (error-cruft `(record-accessor ,rt ',name))) - (lambda (r) - (if (eq? (record-type r) rt) - (record-ref r index) - (call-error "invalid record access" error-cruft r))))) - -(define (record-modifier rt name) - (let ((index (record-field-index rt name)) - (error-cruft `(record-modifier ,rt ',name))) - (lambda (r x) - (if (eq? (record-type r) rt) - (record-set! r index x) - (call-error "invalid record modification" error-cruft r x))))) - -(define (record-predicate rt) - (lambda (x) - (and (record? x) - (eq? (record-type x) rt)))) - -;---------------- -; A discloser is a procedure that takes a record of a particular type and -; returns a list whose head is a string or symbol and whose tail is other -; stuff. -; -; Set the discloser for record type RT. - -(define (define-record-discloser rt proc) - (if (and (record-type? rt) - (procedure? proc)) - (set-record-type-discloser! rt proc) - (call-error "invalid argument" define-record-discloser rt proc))) - -; By default we just return the name of the record type. - -(define (make-default-record-discloser record-type-name) - (lambda (r) - (list record-type-name))) - -; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list. - -(define (disclose-record r) - (if (record? r) - (let ((rt (record-type r))) - (if (record-type? rt) - ((record-type-discloser rt) r) - #f)) - #f)) - -;---------------- -; A resumer is a procedure that the VM calls on all records of a given -; type on startup. -; -; A resumer may be: -; #t -> do nothing on startup. -; #f -> records of this type do not survive a dump/resume; in images they -; are replaced by their first slot (so we make sure they have one) -; a one-argument procedure -> pass the record to this procedure -; -; Resumers are primarily intended for use by external code which keeps -; fields in records which do not survive a dump under their own power. -; For example, a record may contain a reference to a OS-dependent value. -; -; Resumers are called by the VM on startup. - -(define (define-record-resumer rt resumer) - (if (and (record-type? rt) - (or (eq? #t resumer) - (and (eq? #f resumer) - (< 0 (record-type-number-of-fields rt))) - (procedure? resumer))) - (set-record-type-resumer! rt resumer) - (call-error "invalid argument" define-record-resumer rt resumer))) - -; By default we leave records alone. - -(define default-record-resumer - #t) - -(define (initialize-records! resumer-records) - (if (vector? resumer-records) - (do ((i 0 (+ i 1))) - ((= i (vector-length resumer-records))) - (resume-record (vector-ref resumer-records i))))) - -(define (resume-record record) - ((record-type-resumer (record-type record)) - record)) - -;---------------- -; Initializing *RECORD-TYPE* and making a type. - -(set! *record-type* - (make-record-type 'record-type record-type-fields)) - -(record-set! *record-type* 0 *record-type*) - -(define :record-type *record-type*) - -(define-record-discloser :record-type - (lambda (rt) - (list 'record-type - (record-type-uid rt) - (record-type-name rt)))) diff --git a/module/srfi/srfi-9-psyntax.mes b/module/srfi/srfi-9-psyntax.mes deleted file mode 100644 index 78ab8b9f..00000000 --- a/module/srfi/srfi-9-psyntax.mes +++ /dev/null @@ -1,29 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; srfi-9.mes - records. - -(mes-use-module (mes scm)) -(mes-use-module (mes psyntax)) -(mes-use-module (mes record-0)) -(mes-use-module (mes record)) -(include-from-path "srfi/srfi-9.scm") diff --git a/module/srfi/srfi-9.mes b/module/srfi/srfi-9.mes index 104c188e..04d2f9c0 100644 --- a/module/srfi/srfi-9.mes +++ b/module/srfi/srfi-9.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2017 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -22,8 +22,116 @@ ;;; srfi-9.mes - records. -(mes-use-module (mes scm)) -(mes-use-module (mes syntax)) -(mes-use-module (mes record-0)) -(mes-use-module (mes record)) -(include-from-path "srfi/srfi-9.scm") +(define (lst-index lst o) + (let loop ((lst lst) (i 0)) + (and (pair? lst) + (if (equal? o (car lst)) i + (loop (cdr lst) (1+ i)))))) + +(define (make-record-type type fields) + (list->vector (list '*record-type* type fields (length fields)))) + +(define (record-type o) + (vector-ref o 0)) + +(define (record-type? o) + (eq? (record-type o) '*record-type*)) + +(define (record-constructor type params) + (let ((fields (record-fields type))) + (lambda (. o) + (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor") + (let ((rest (make-list (- (length fields) (length params))))) + (list->vector (cons type (append o rest)))))))) + +(define (record-fields o) + (vector-ref o 2)) + +(define (record-field-index type field) + (1+ (or (lst-index (record-fields type) field) + (error "no such field" type field)))) + +(define (record-getter type field) + (let ((i (record-field-index type field))) + (lambda (o) + (if (not (eq? (record-type o) type)) (error "record getter: record expected" type o) + (vector-ref o i))))) + +(define (record-setter type field) + (let ((i (record-field-index type field))) + (lambda (o v) + (if (not (eq? (record-type o) type)) (error "record setter: record expected" type o) + (vector-set! o i v))))) + +(define (record-predicate type) + (lambda (o) + (and (vector? o) + (eq? (record-type o) type)))) + +(define-macro (define-record-accessors type . fields) + `(begin + ,@(map (lambda (field) + `(define-record-accessor ,type ,field)) + fields))) + +(define-macro (define-record-accessor type field) + `(begin + (define ,(cadr field) ,(record-getter type (car field))) + (if ,(pair? (cddr field)) + (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field)))))) + +(define-macro (define-record-type type constructor+params predicate . fields) + (let ((record (make-record-type type (map car fields)))) + `(begin + (define ,type ,record) + (define ,(car constructor+params) ,(record-constructor record (cdr constructor+params))) + (define ,predicate ,(record-predicate record)) + (define-record-accessors ,record ,@fields)))) + +;; (define-record-type cpi +;; (make-cpi-1) +;; cpi? +;; (debug cpi-debug set-cpi-debug!) ; debug #t #f +;; (defines cpi-defs set-cpi-defs!) ; #defines +;; (incdirs cpi-incs set-cpi-incs!) ; #includes +;; (inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames +;; (inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines +;; (ptl cpi-ptl set-cpi-ptl!) ; parent typename list +;; (ctl cpi-ctl set-cpi-ctl!) ; current typename list +;; (blev cpi-blev set-cpi-blev!) ; curr brace/block level +;; ) + +;; (display cpi) +;; (newline) +;; (display make-cpi-1) +;; (newline) +;; (define cpi (make-cpi-1)) +;; (set-cpi-debug! cpi #t) +;; (set-cpi-blev! cpi #t) + + +;; (define-record-type (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary)) + +;; (display ) +;; (newline) +;; (display make-employee) +;; (newline) +;; (display "employee-age ") +;; (display employee-age) +;; (newline) + +;; (display "set-employee-age! ") +;; (display set-employee-age!) +;; (newline) + +;; (define janneke (make-employee "janneke" 49 42)) +;; (display janneke) +;; (newline) + +;; (display (employee-age janneke)) +;; (newline) + +;; (display (set-employee-age! janneke 33)) +;; (newline) +;; (display (employee-age janneke)) +;; (newline) diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm deleted file mode 100644 index 47b51617..00000000 --- a/module/srfi/srfi-9.scm +++ /dev/null @@ -1,100 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; srfi-9.mes - records. Assumes record-0.mes and record.mes are -;;; available. Modified from -;;; scheme48-1.1/scheme/alt/jar-defrecord.scm to implement SRFI-9. - -;;; Code: - -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. - -;;; scheme48-1.1/COPYING - -;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees -;; All rights reserved. - -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions -;; are met: -;; 1. Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; 2. Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; 3. The name of the authors may not be used to endorse or promote products -;; derived from this software without specific prior written permission. - -;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -; This is JAR's define-record-type, which doesn't resemble Richard's. - -; There's no implicit name concatenation, so it can be defined -; entirely using syntax-rules. Example: -; (define-record-type foo :foo -; (make-foo x y) -; foo? - predicate name is optional -; (x foo-x) -; (y foo-y) -; (z foo-z set-foo-z!)) - -(define-syntax define-record-type - (syntax-rules () - ((define-record-type type - (constructor arg ...) - (field . field-stuff) - ...) - (begin (define type (make-record-type 'type '(field ...))) - (define constructor (record-constructor type '(arg ...))) - (define-accessors type (field . field-stuff) ...))) - ((define-record-type type - (constructor arg ...) - pred - more ...) - (begin (define-record-type type - (constructor arg ...) - more ...) - (define pred (record-predicate type)))))) - -;; Straightforward version -(define-syntax define-accessors - (syntax-rules () - ((define-accessors type field-spec ...) - (begin (define-accessor type . field-spec) ...)))) - -(define-syntax define-accessor - (syntax-rules () - ((define-accessor type field accessor) - (define accessor (record-accessor type 'field))) - ((define-accessor type field accessor modifier) - (begin (define accessor (record-accessor type 'field)) - (define modifier (record-modifier type 'field))))))