1 files changed, 277 insertions, 0 deletions
diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Lib/old-obj.scm b/js/games/nluqo.github.io/~bh/61a-pages/Lib/old-obj.scm
new file mode 100644
index 0000000..cee6aae
--- /dev/null
+++ b/js/games/nluqo.github.io/~bh/61a-pages/Lib/old-obj.scm
@@ -0,0 +1,277 @@
+;;; obj.scm version 3.0 1/9/95
+;;; -- implementation of the object-oriented syntax
+;;; This version is supposed to work with Unix SCM, PC SCM, and Mac Gambit
+;;; This version does class names right.
+;;; Also, explicit methods come before instance variable methods
+;; By Matt Wright, based on a handout from MIT
+
+;; ASK: send a message to an object
+
+; The dot in the first line of the definition of ASK, below, makes it
+; take a variable number of arguments.  The first argument is associated
+; with the formal parameter OBJECT; the second with MESSAGE; any extra
+; actual arguments are put in a list, and that list is associated with
+; the formal parameter ARGS.  (If there are only two actual args, then
+; ARGS will be the empty list.)
+
+; APPLY takes two arguments, a procedure and a list, and applies the
+; procedure to the things in the list, which are used as actual
+; argument values.
+
+(define (ask object message . args)
+  (let ((method (object message)))
+    (if (method? method)
+	(apply method args)
+	(error "No method" message (cadr method)))))
+
+(define (no-method name)
+  (list 'no-method name))
+
+(define (no-method? x)
+  (if (pair? x)
+      (eq? (car x) 'no-method)
+      #f))
+
+(define (method? x)
+  (not (no-method? x)))
+
+
+;; INSTANTIATE and INSTANTIATE-PARENT:  Create an instance of a class
+
+; The difference is that only INSTANTIATE initializes the new object
+
+(define (instantiate class . arguments)
+  (let ((new-instance (apply (class 'instantiate) arguments)))
+    (ask new-instance 'initialize new-instance)
+    new-instance))
+
+(define (instantiate-parent class . arguments)
+  (apply (class 'instantiate) arguments))
+
+;; GET-METHOD: Send a message to several objects and return the first
+;; method found (for multiple inheritance)
+
+(define (get-method give-up-name message . objects)
+  (if (null? objects)
+      (no-method give-up-name)
+      (let ((method ((car objects) message)))
+	(if (method? method)
+	    method
+	    (apply get-method (cons give-up-name
+				    (cons message (cdr objects)) ))))))
+
+
+
+;; USUAL: Invoke a parent's method
+;; Note: The 'send-usual-to-parent method is put in automatically by
+;; define-class.
+
+(if scm?
+    (defmacro usual args `(ask dispatch 'send-usual-to-parent . ,args))
+    (eval '(define-macro (usual . args)
+	     `(ask dispatch 'send-usual-to-parent . ,args))))
+
+
+;; DEFINE-CLASS:  Create a new class.
+
+; DEFINE-CLASS is a special form.  When you type (define-class body...)
+; it's as if you typed (make-definitions (quote body...)).  In other
+; words, the argument to DEFINE-CLASS isn't evaluated.  This makes sense
+; because the argument isn't Scheme syntax, but rather is the special
+; object-oriented programming language we're defining.
+; Make-definitions transforms the OOP notation into a standard Scheme
+; expression, then uses EVAL to evaluate the result.  (You'll see EVAL
+; again in chapter 4 with the metacircular evaluator.)
+
+; When you define a class named THING, for example, two global Scheme
+; variables are created.  The variable THING has as its value the
+; procedure that represents the class.  This procedure is invoked by
+; INSTANTIATE to create instances of the class.  A second variable,
+; THING-DEFINITION, has as its value the text of the Scheme expression
+; that defines THING.  This text is used only by SHOW-CLASS, the
+; procedure that lets you examine the result of the OOP-to-Scheme
+; translation process.
+
+(if scm?
+    (defmacro define-class body (make-definitions body))
+    (eval '(define-macro (define-class . body) (make-definitions body))))
+
+(define (make-definitions form)
+  (let ((definition (translate form)))
+    (eval `(define ,(word (class-name form) '-definition) ',definition))
+    (eval definition)
+    (list 'quote (class-name form))))
+
+(define (show-class name)
+  (eval (word name '-definition)) )
+
+; TRANSLATE does all the work of DEFINE-CLASS.
+; The backquote operator (`) works just like regular quote (') except
+; that expressions proceeded by a comma are evaluated.  Also, expressions
+; proceeded by ",@" evaluate to lists; the lists are inserted into the
+; text without the outermost level of parentheses.
+
+(define (translate form)
+  (cond ((null? form) (error "Define-class: empty body"))
+	((not (null? (obj-filter form (lambda (x) (not (pair? x))))))
+	 (error "Each argument to define-class must be a list"))
+	((not (null? (extra-clauses form)))
+	 (error "Unrecognized clause in define-class:" (extra-clauses form)))
+	(else 
+	 `(define ,(class-name form)
+	    (let ,(class-var-bindings form)
+	      (lambda (class-message)
+		(cond
+		 ,@(class-variable-methods form)
+		 ((eq? class-message 'instantiate)
+		  (lambda ,(instantiation-vars form)
+		    (let ((self '())
+			  ,@(parent-let-list form)
+			  ,@(instance-vars-let-list form))
+		      (define (dispatch message)
+			(cond
+			 ,(init-clause form)
+			 ,(usual-clause form)
+			 ,@(method-clauses form)
+			 ,@(local-variable-methods form)
+			 ,(else-clause form) ))
+		      dispatch )))
+		 (else (error "Bad message to class" class-message)) )))))))
+
+(define *legal-clauses*
+  '(instance-vars class-vars method default-method parent initialize))
+
+(define (extra-clauses form)
+  (obj-filter (cdr form)
+	      (lambda (x) (not (member? (car x) *legal-clauses*)))))
+
+(define class-name caar)
+
+(define (class-var-bindings form)
+  (let ((classvar-clause (find-a-clause 'class-vars form)))
+    (if (null? classvar-clause)
+	'()
+	(cdr classvar-clause) )))
+
+(define instantiation-vars cdar)
+
+(define (parent-let-list form)
+  (let ((parent-clause (find-a-clause 'parent form)))
+    (if (null? parent-clause)
+	'()
+	(map (lambda (parent-and-args)
+	       (list (word 'my- (car parent-and-args))
+		     (cons 'instantiate-parent parent-and-args)))
+	     (cdr parent-clause)))))
+
+(define (instance-vars-let-list form)
+  (let ((instance-vars-clause (find-a-clause 'instance-vars form)))
+    (if (null? instance-vars-clause)
+	'()
+	(cdr instance-vars-clause))))
+
+(define (init-clause form)
+  (define (parent-initialization form)
+    (let ((parent-clause (find-a-clause 'parent form)))
+      (if (null? parent-clause)
+	  '()
+	  (map
+	   (lambda (parent-and-args)
+	     `(ask ,(word 'my- (car parent-and-args)) 'initialize self) )
+	   (cdr parent-clause) ))))
+  (define (my-initialization form)
+    (let ((init-clause (find-a-clause 'initialize form)))
+      (if (null? init-clause) '()
+	  (cdr init-clause))))
+  (define (init-body form)
+    (append (parent-initialization form)
+	    (my-initialization form) ))
+
+  `((eq? message 'initialize)
+    (lambda (value-for-self)
+      (set! self value-for-self)
+      ,@(init-body form) )))
+
+(define (variable-list var-type form)
+  (let ((clause (find-a-clause var-type form)))
+    (if (null? clause)
+	'()
+	(map car (cdr clause)) )))
+
+(define (class-variable-methods form)
+  (cons `((eq? class-message 'class-name) (lambda () ',(class-name form)))
+	(map (lambda (variable)
+	       `((eq? class-message ',variable) (lambda () ,variable)))
+	     (variable-list 'class-vars form))))
+
+(define (local-variable-methods form)
+  (cons `((eq? message 'class-name) (lambda () ',(class-name form)))
+	(map (lambda (variable)
+	       `((eq? message ',variable) (lambda () ,variable)))
+	     (append (cdr (car form))
+		     (variable-list 'instance-vars form)
+		     (variable-list 'class-vars form)))))
+
+(define (method-clauses form)
+  (map
+   (lambda (method-defn)
+     (let ((this-message (car (cadr method-defn)))
+	   (args (cdr (cadr method-defn)))
+	   (body (cddr method-defn)))
+       `((eq? message ',this-message)
+	 (lambda ,args ,@body))))
+   (obj-filter (cdr form) (lambda (x) (eq? (car x) 'method))) ))
+
+(define (parent-list form)
+  (let ((parent-clause (find-a-clause 'parent form)))
+    (if (null? parent-clause)
+	'()
+	(map (lambda (class) (word 'my- class))
+	     (map car (cdr parent-clause))))))
+
+(define (usual-clause form)
+  (let ((parent-clause (find-a-clause 'parent form)))
+    (if (null? parent-clause)
+	`((eq? message 'send-usual-to-parent)
+	  (error "Can't use USUAL without a parent." ',(class-name form)))
+	`((eq? message 'send-usual-to-parent)
+	  (lambda (message . args)
+	    (let ((method (get-method ',(class-name form)
+				      message
+				      ,@(parent-list form))))
+	      (if (method? method)
+		  (apply method args)
+		  (error "No USUAL method" message ',(class-name form)) )))))))
+
+(define (else-clause form)
+  (let ((parent-clause (find-a-clause 'parent form))
+	(default-method (find-a-clause 'default-method form)))
+    (cond
+     ((and (null? parent-clause) (null? default-method))
+      `(else (no-method ',(class-name form))))
+     ((null? parent-clause)
+      `(else (lambda args ,@(cdr default-method))))
+     ((null? default-method)
+      `(else (get-method ',(class-name form) message ,@(parent-list form))) )
+     (else
+      `(else (let ((method (get-method ',(class-name form)
+				       message
+				       ,@(parent-list form))))
+	       (if (method? method)
+		   method
+		   (lambda args ,@(cdr default-method)) )))))))
+
+(define (find-a-clause clause-name form)
+  (let ((clauses (obj-filter (cdr form)
+			     (lambda (x) (eq? (car x) clause-name)))))
+    (cond ((null? clauses) '())
+	  ((null? (cdr clauses)) (car clauses))
+	  (else (error "Error in define-class: too many "
+		       clause-name "clauses.")) )))
+
+(define (obj-filter l pred)
+  (cond ((null? l) '())
+	((pred (car l))
+	 (cons (car l) (obj-filter (cdr l) pred)))
+	(else (obj-filter (cdr l) pred))))
+