From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 15 Mar 1991 23:26:19 +0000 (+0000)
Subject: * Fix `define-named-structure' to make the definitions of slot indices
X-Git-Tag: 20090517-FFI~10852
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eecb855a671e65eece0dd42eabd7205c4bb7719c;p=mit-scheme.git

* Fix `define-named-structure' to make the definitions of slot indices
  integrable.

* Change `define-command' to give a meaningful debugging name to the
  procedure that implements the command.

* Change `define-variable' to accept an optional fourth argument,
  which is a value validity test.
---

diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm
index cee6dc2bc..65f29f7bf 100644
--- a/v7/src/edwin/macros.scm
+++ b/v7/src/edwin/macros.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.49 1989/08/11 11:50:41 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.50 1991/03/15 23:26:19 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -75,7 +75,7 @@
 	(define (slot-loop slot-names n)
 	  (if (null? slot-names)
 	      '()
-	      (cons `(DEFINE ,(car slot-names) ,n)
+	      (cons `(DEFINE-INTEGRABLE ,(car slot-names) ,n)
 		    (slot-loop (cdr slot-names) (1+ n)))))
 
 	(define (selector-loop selector-names n)
@@ -105,15 +105,22 @@
 (syntax-table-define edwin-syntax-table 'DEFINE-COMMAND
   (lambda (name description interactive procedure)
     (let ((name (canonicalize-name name)))
-      `(BEGIN
-	 (DEFINE ,(command-name->scheme-name name)
-	   (MAKE-COMMAND ',name
-			 ',description
-			 ,(if (null? interactive)
-			      `'()
-			      interactive)
-			 ,procedure))
-	 ',name))))
+      (let ((scheme-name (command-name->scheme-name name)))
+	`(BEGIN
+	   (DEFINE ,scheme-name
+	     (MAKE-COMMAND ',name
+			   ',description
+			   ,(if (null? interactive)
+				`'()
+				interactive)
+			   ,(if (and (pair? procedure)
+				     (eq? 'LAMBDA (car procedure))
+				     (pair? (cdr procedure)))
+				`(NAMED-LAMBDA (,scheme-name
+						,@(cadr procedure))
+				   ,@(cddr procedure))
+				procedure)))
+	   ',name)))))
 
 (syntax-table-define edwin-syntax-table 'REF-COMMAND-OBJECT
   (lambda (name)
@@ -129,15 +136,20 @@
 
 (let ((variable-definition
        (lambda (buffer-local?)
-	 (lambda (name description #!optional value)
+	 (lambda (name description #!optional value test)
 	   (let ((name (canonicalize-name name)))
-	     `(BEGIN
-		(DEFINE ,(variable-name->scheme-name name)
-		  (MAKE-VARIABLE ',name
-				 ',description
-				 ,(if (default-object? value) '#F value)
-				 ',buffer-local?))
-		',name))))))
+	     (let ((scheme-name (variable-name->scheme-name name)))
+	       `(BEGIN
+		  (DEFINE ,scheme-name
+		    (MAKE-VARIABLE ',name
+				   ',description
+				   ,(if (default-object? value) '#F value)
+				   ',buffer-local?))
+		  ,@(if (default-object? test)
+			'()
+			`((DEFINE-VARIABLE-VALUE-VALIDITY-TEST ,scheme-name
+			    ,test)))
+		  ',name)))))))
   (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
     (variable-definition false))
   (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER