All pastes #903477 Raw Edit

Mine

public text v1 · immutable
·published 2008-02-14 09:56 UTC
rendered paste body
(define-syntax define-command
  (rsc-macro-transformer
   (lambda (form environment)
     (capture-syntactic-environment
      (lambda (instance-environment)
	(if (syntax-match? '(SYMBOL EXPRESSION EXPRESSION EXPRESSION)
			   (cdr form))
	    (let ((name (list-ref form 1))
		  (description (list-ref form 2))
		  (interactive (list-ref form 3))
		  (procedure (list-ref form 4)))
	      (let ((scheme-name (command-name->scheme-name name)))
		`(,(close-syntax 'DEFINE environment)
		  ,scheme-name
		   (,(close-syntax 'MAKE-COMMAND environment)
		    ',name
		    ,description
		    ,interactive
		    ,(if (and (pair? procedure)
			      (identifier=?
			       instance-environment (car procedure)
			       environment 'LAMBDA)
			      (pair? (cdr procedure)))
			 `(,(close-syntax 'NAMED-LAMBDA environment)
			   (,scheme-name ,@(cadr procedure))
			   ,@(cddr procedure))
			 procedure)))))
	    (ill-formed-syntax form)))))))


(define-syntax define-command
  (lambda (form rename compare)
    (if (not (= (length form) 5))
        (syntax-error "DEFINE-COMMAND name description interactive procedure")
        (let* ((name          (list-ref form 1))
               (description   (list-ref form 2))
               (interactive   (list-ref form 3))
               (procedure     (list-ref form 4))
               (scheme-name   (command-name->scheme-name name))
               (%define       (rename 'define))
               (%make-command (rename 'make-command)))
          `(,%define ,scheme-name
                     (,%make-command ',name ,description ,interactive ,procedure))))))