You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
106 lines
4.5 KiB
Scheme
106 lines
4.5 KiB
Scheme
;; expander-boot.ss
|
|
; ----------------------------------------------------------------------
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
|
;
|
|
; This program is free software; you can redistribute it and/or
|
|
; modify it under the terms of the GNU General Public License
|
|
; version 2 as published by the Free Software Foundation.
|
|
;
|
|
; This program 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 this program; if not, write to the Free Software
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
; ----------------------------------------------------------------------
|
|
(printf "Loading expander-boot.ss~n")
|
|
|
|
(define __keep-mrspidey-annotations #t)
|
|
(load "~cormac/scheme/mzschemerc.ss")
|
|
(match:set-error-control 'error)
|
|
|
|
(defmacro assert args '(void))
|
|
(defmacro begin-test-case args `(begin ,@args))
|
|
;(defmacro type: args `(type:-quote (quote ,args)))
|
|
(defmacro primitive: args `(type: ,@args))
|
|
|
|
(defmacro include-exp (f)
|
|
(let ([p (open-input-file f)])
|
|
(begin0
|
|
(read p)
|
|
(close-input-port p))))
|
|
|
|
;; ---------- structures --------------------------------------------------
|
|
;; field = (: sym type) | (! sym type) | sym
|
|
;; field-name = sym
|
|
|
|
(define (struct-expander-fn struct: const?)
|
|
(#%let ([make-exn make-exn:syntax]
|
|
[debug debug-info-handler])
|
|
(#%lambda body
|
|
(#%let* ([syntax-error
|
|
(#%lambda (s)
|
|
(#%raise
|
|
(make-exn
|
|
(#%format "define-struct: ~a" s)
|
|
((debug))
|
|
(#%cons 'define-struct body))))]
|
|
[field->field-name
|
|
(match-lambda
|
|
[((or ': '!) sym _) sym]
|
|
[(? symbol? sym) sym]
|
|
[x (syntax-error (format "Bad field ~s" x))])]
|
|
[field-mutable?
|
|
(match-lambda
|
|
[('! sym _) #t]
|
|
[_ (not const?)])]
|
|
[build-struct-names
|
|
(#%lambda (name fields)
|
|
(#%let ([name (#%symbol->string name)]
|
|
[+ #%string-append])
|
|
(#%map #%string->symbol
|
|
(#%append
|
|
(#%list
|
|
(+ "struct:" name)
|
|
(+ "make-" name)
|
|
(+ name "?"))
|
|
(#%apply
|
|
#%append
|
|
(#%map
|
|
(#%lambda (field)
|
|
(let ([f
|
|
(symbol->string
|
|
(field->field-name field))])
|
|
(cons
|
|
(+ name "-" f)
|
|
(if (field-mutable? field)
|
|
(list (+ "set-" name "-" f "!"))
|
|
'()))))
|
|
fields))))))])
|
|
(#%or (#%pair? body)
|
|
(syntax-error "empty declaration"))
|
|
(#%or (#%= 2 (#%length body))
|
|
(syntax-error "wrong number of parts"))
|
|
(#%or (#%symbol? (#%car body))
|
|
(#%and (#%pair? (#%car body))
|
|
(#%symbol? (#%caar body))
|
|
(#%pair? (#%cdar body))
|
|
(#%null? (#%cddar body)))
|
|
(syntax-error "first part must be an identifier or identifier-expression pair"))
|
|
(#%or (#%list? (#%cadr body))
|
|
(syntax-error "improper field list"))
|
|
(#%let* ([name (#%if (#%symbol? (#%car body))
|
|
(#%car body)
|
|
(#%caar body))]
|
|
[fields (#%cadr body)])
|
|
`(#%define-values ,(build-struct-names name fields)
|
|
(,struct: ,@body)))))))
|
|
|
|
;(#%define-macro define-const-typed-structure (struct-expander-fn '#%const-typed-structure #t))
|
|
(#%define-macro define-const-typed-structure (struct-expander-fn '#%typed-structure #f))
|
|
(#%define-macro define-typed-structure (struct-expander-fn '#%typed-structure #f))
|
|
|
|
(printf "expander-boot.ss done~n")
|