124 lines
4.1 KiB
Scheme
124 lines
4.1 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme 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 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Class/Object System
|
||
|
||
|
||
|
||
;;; ******************************************************************
|
||
;;; This software is intended for use in the Edwin window system only.
|
||
;;; Don't think about using it for anything else, since it is not, and
|
||
;;; likely will not ever, be supported as a part of the Scheme system.
|
||
;;; ******************************************************************
|
||
|
||
(define-syntax define-class
|
||
(rsc-macro-transformer
|
||
(lambda (form environment)
|
||
(if (and (syntax-match? '(identifier datum (* symbol)) (cdr form))
|
||
(or (identifier? (caddr form))
|
||
(null? (caddr form))))
|
||
(let ((name (cadr form))
|
||
(superclass (if (null? (caddr form)) #f (caddr form)))
|
||
(variables (cadddr form)))
|
||
;; Compile-time definition.
|
||
(make-class (identifier->symbol name)
|
||
(and superclass
|
||
(name->class (identifier->symbol superclass)))
|
||
variables)
|
||
;; Load-time definition.
|
||
`(,(close-syntax 'define environment)
|
||
,name
|
||
(,(close-syntax 'make-class environment)
|
||
',(identifier->symbol name)
|
||
,superclass
|
||
',variables)))
|
||
(ill-formed-syntax form)))))
|
||
|
||
(define-syntax define-method
|
||
(rsc-macro-transformer
|
||
(lambda (form environment)
|
||
(let ((finish
|
||
(lambda (name operation expression)
|
||
`(,(close-syntax 'class-method-define environment)
|
||
,name
|
||
',operation
|
||
,expression))))
|
||
(cond ((syntax-match? '(identifier symbol expression) (cdr form))
|
||
(finish (cadr form) (caddr form) (cadddr form)))
|
||
((and (syntax-match? '(identifier (symbol . mit-bvl) + expression)
|
||
(cdr form))
|
||
(pair? (cdr (caddr form)))
|
||
(identifier? (cadr (caddr form))))
|
||
(finish (cadr form)
|
||
(car (caddr form))
|
||
`(,(close-syntax 'named-lambda environment)
|
||
,(caddr form)
|
||
(,(close-syntax 'with-instance-variables environment)
|
||
,(cadr form)
|
||
,(cadr (caddr form))
|
||
()
|
||
,@(cdddr form)))))
|
||
(else
|
||
(ill-formed-syntax form)))))))
|
||
|
||
(define with-instance-variables
|
||
(classifier->runtime
|
||
(lambda (form senv hist)
|
||
(syntax-check '(_ identifier expression (* identifier) + expression) form)
|
||
(let ((class-name (cadr form))
|
||
(self-item
|
||
(classify-form (caddr form) senv (hist-car (hist-cddr hist))))
|
||
(free-names (cadddr form))
|
||
(body-item
|
||
(classify-form `(,(close-syntax 'begin
|
||
(runtime-environment->syntactic
|
||
system-global-environment))
|
||
,@(cddddr form))
|
||
senv
|
||
(hist-cddr (hist-cddr hist)))))
|
||
(expr-item #f (list self-item body-item)
|
||
(lambda (self body)
|
||
(transform-instance-variables
|
||
(class-instance-transforms
|
||
(name->class (identifier->symbol class-name)))
|
||
self
|
||
free-names
|
||
body))
|
||
(lambda (self body)
|
||
`(with-instance-variables ,class-name ,self ,free-names ,body)))))))
|
||
|
||
(define-syntax ==>
|
||
(syntax-rules ()
|
||
((==> object operation argument ...)
|
||
(let ((temp object))
|
||
((object-method temp 'operation) temp argument ...)))))
|
||
|
||
(define-syntax usual==>
|
||
(syntax-rules ()
|
||
((usual==> object operation argument ...)
|
||
(let ((temp object))
|
||
((usual-method (object-class temp) 'operation) temp argument ...)))))
|