SRFI-26のcutマクロの各実装まとめ

cut-macro-matome.scm

(define-syntax cut
  (syntax-rules ()
    ((cut . slots-or-exprs)
     (srfi-26-internal-cut () () . slots-or-exprs))))

(define-syntax cut-sc
  (sc-macro-transformer
   (lambda (form env)
     `(cut%-sc () () ,@(map (lambda (ex)
			      (make-syntactic-closure env '() ex))
			    (cdr form))))))

(define-syntax cut-sc2
  (sc-macro-transformer
   (lambda (form env)
     `(cut%-sc2 () () ,@(cdr form)))))

(define-syntax cut-sc3
  (sc-macro-transformer
   (lambda (form use-env)
     `(%cut-sc3 () () ,@(map (lambda (x)
			   (close-syntax x use-env))
			 (cdr form))))))

(define-syntax cut-rsc
  (rsc-macro-transformer
   (lambda (form env)
     (let ((cut%-rsc-r (make-syntactic-closure env '() 'cut%-rsc)))
       `(,cut%-rsc-r () () ,@(cdr form))))))

(define-syntax cut-er
  (er-macro-transformer
   (lambda (form rename compare?)
     `(,(rename 'cut%-er) () () ,@(cdr form)))))

(define-syntax cut-ir
  (ir-macro-transformer
   (lambda (form inject compare?)
     `(cut%-ir () () ,@(cdr form)))))

(define-syntax srfi-26-internal-cut
  (syntax-rules (<> <...>)

    ;; construct fixed- or variable-arity procedure:
    ;;   (begin proc) throws an error if proc is not an <expression>
    ((srfi-26-internal-cut (slot-name ...) (proc arg ...))
     (lambda (slot-name ...) ((begin proc) arg ...)))
    ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>)
     (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))

    ;; process one slot-or-expr
    ((srfi-26-internal-cut (slot-name ...)   (position ...)      <>  . se)
     (srfi-26-internal-cut (slot-name ... x) (position ... x)        . se))
    ((srfi-26-internal-cut (slot-name ...)   (position ...)      nse . se)
     (srfi-26-internal-cut (slot-name ...)   (position ... nse)      . se))))

(define-syntax cut%-sc
  (sc-macro-transformer
   (lambda (form env)
     (let ((slots (cadr form))
	   (combi (caddr form))
	   (se (cdddr form)))
       (define (id=? x y)
	 (and (identifier? x)
	      (identifier=? env x env y)))
       (cond ((null? se)
	      (let ((slots (reverse slots))
		    (combi (reverse combi)))
		`(lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))
	     ((id=? (car se) '<...>)
	      (let ((slots (reverse slots))
		    (combi (reverse combi))
		    (rest-slot (make-syntactic-closure env '() 'rest-slot)))
		`(lambda (,@slots ,@rest-slot) (apply ,@combi ,rest-slot))))
	     ((id=? (car se) '<>)
	      (let ((x (make-syntactic-closure env '() 'x)))
		(let ((slots (cons x slots))
		      (combi (cons x combi)))
		  `(cut%-sc ,slots ,combi ,@(cdr se)))))
	     (else
	      (let ((combi (cons (car se) combi)))
		`(cut%-sc ,slots ,combi ,@(cdr se)))))))))

(define-syntax cut%-sc2
  (sc-macro-transformer
   (lambda (form env)
     (let ((slots (cadr form))
	   (combi (caddr form))
	   (se (cdddr form)))
       (cond ((null? se)
	      (let ((slots (reverse slots))
		    (combi (reverse combi)))
		`(lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))
	     ((eq? (car se) '<...>)
	      (let ((slots (reverse slots))
		    (combi (reverse combi))
		    (rest-slot (make-syntactic-closure env '() 'rest-slot)))
		`(lambda (,@slots ,@rest-slot) (apply ,@combi ,rest-slot))))
	     ((eq? (car se) '<>)
	      (let ((x (make-syntactic-closure env '() 'x)))
		(let ((slots (cons x slots))
		      (combi (cons x combi)))
		  `(cut%-sc2 ,slots ,combi ,@(cdr se)))))
	     (else
	      (let ((combi (cons (make-syntactic-closure env '() (car se))
				 combi)))
		`(cut%-sc2 ,slots ,combi ,@(cdr se)))))))))

(define-syntax %cut-sc3
  (sc-macro-transformer
   (lambda (form use-env)
     (capture-syntactic-environment
      (lambda (mac-env)
	(let ((rargs (cadr form))
	      (rbody (caddr form))
	      (rest (cdddr form)))
	  (define (id=? x y)
	    (and (identifier? x)
		 (identifier=? use-env x mac-env y)))
	  (cond ((null? rest)
		 `(lambda ,(reverse rargs) ,(reverse rbody)))
		((and (id=? (car rest) '<...>)
		      (null? (cdr rest)))
		 `(lambda (,@(reverse rargs) ,@'r)
		    (apply ,@(reverse rbody) r)))
		((id=? (car rest) '<>)
		 (let ((arg (make-synthetic-identifier 'arg)))
		   `(%cut-sc3 (,arg ,@rargs) (,arg ,@rbody) ,@(cdr rest))))
		(else
		 `(%cut-sc3 ,rargs (,(car rest) ,@rbody) ,@(cdr rest))))))))))

(define-syntax cut%-rsc
  (rsc-macro-transformer
   (lambda (form env)
     (let ((slots (cadr form))
	   (combi (caddr form))
	   (se (cdddr form))
	   (lambda-r (make-syntactic-closure env '() 'lambda))
	   (begin-r (make-syntactic-closure env '() 'begin))
	   (apply-r (make-syntactic-closure env '() 'apply))
	   (cut%-rsc-r (make-syntactic-closure env '() 'cut%-rsc)))
       (cond ((null? se)
	      (let ((slots (reverse slots))
		    (combi (reverse combi)))
		`(,lambda-r ,slots ((,begin-r ,(car combi)) ,@(cdr combi)))))
	     ((eq? (car se) '<...>)
	      (let ((slots (reverse slots))
		    (combi (reverse combi))
		    (rest-slot (make-syntactic-closure env '() 'rest-slot)))
		`(,lambda-r (,@slots ,@rest-slot)
		   (,apply-r ,@combi ,rest-slot))))
	     ((eq? (car se) '<>)
	      (let ((x (make-syntactic-closure env '() 'x)))
		(let ((slots (cons x slots))
		      (combi (cons x combi)))
		  `(,cut%-rsc-r ,slots ,combi ,@(cdr se)))))
	     (else
	      (let ((combi (cons (car se) combi)))
		`(,cut%-rsc-r ,slots ,combi ,@(cdr se)))))))))

(define-syntax cut%-er
  (er-macro-transformer
   (lambda (form rename compare?)
     (let ((slots (cadr form))
	   (combi (caddr form))
	   (se (cdddr form)))
       (cond ((null? se)
	      (let ((slots (reverse slots))
		    (combi (reverse combi)))
		`(,(rename 'lambda) ,slots
		  ((,(rename 'begin) ,(car combi)) ,@(cdr combi)))))
	     ((and (symbol? (car se))
		   (compare? (car se) (rename '<...>)))
	      (let ((slots (reverse slots))
		    (combi (reverse combi))
		    (rest-slot (rename 'rest-slot)))
		`(,(rename 'lambda) (,@slots ,@rest-slot)
		  (,(rename 'apply) ,@combi ,rest-slot))))
	     ((and (symbol? (car se))
		   (compare? (car se) (rename '<>)))
	      `(,(rename 'cut%-er)
		,(cons (rename 'x) slots)
		,(cons (rename 'x) combi)
		,@(cdr se)))
	     (else `(,(rename 'cut%-er)
		     ,slots
		     ,(cons (car se) combi)
		     ,@(cdr se))))))))

(define-syntax cut%-ir
    (ir-macro-transformer
     (lambda (form inject compare?)
       (let ((slots (second form))
	     (combi (third form))
	     (se (cdddr form)))
	 (cond ((null? se)
		(let ((slots (reverse slots))
		      (combi (reverse combi)))
		  `(lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))
	       ((and (symbol? (car se))
		     (compare? (car se) '<...>))
		(let ((slots (fold-right cons 'rest-slot (reverse slots)))
		      (combi (reverse (cons 'rest-slot combi))))
		  `(lambda ,slots (apply ,@combi))))
	       ((and (symbol? (car se))
		     (compare? (car se) '<>))
		`(cut% ,(cons 'x slots) ,(cons 'x combi) ,@(cdr se)))
	       (else `(cut% ,slots ,(cons (car se) combi) ,@(cdr se))))))))


;; test
(let ((rest-slot 10))
  ((cut list 0 <> rest-slot <...>) 1 2))
; => (0 1 10 2)

(let ((rest-slot 10))
  ((cut-sc list 0 <> rest-slot <...>) 1 2))
; => (0 1 10 2)

(let ((rest-slot 10))
  ((cut-sc2 list 0 <> rest-slot <...>) 1 2))
; ERROR: undefined variable: rest-slot

(let ((rest-slot 10))
  ((cut-sc3 list 0 <> rest-slot <...>) 1 2))
; => (0 1 10 2)

(let ((rest-slot 10))
  ((cut-rsc list 0 <> rest-slot <...>) 1 2))
; => (0 1 10 2)

(let ((rest-slot 10))
  ((cut-er list 0 <> rest-slot <...>) 1 2))
; => (0 1 10 2)

(let ((<> 10))
  ((cut list 0 <> <...>) 1 2))
; => (0 10 1 2)

(let ((<> 10))
  ((cut-sc list 0 <> <...>) 1 2))
; => (0 10 1 2)

(let ((<> 10))
  ((cut-sc2 list 0 <> <...>) 1 2))
; => (0 1 2)

(let ((<> 10))
  ((cut-sc3 list 0 <> <...>) 1 2))
; => (0 10 1 2)

(let ((<> 10))
  ((cut-rsc list 0 <> <...>) 1 2))
; => (0 1 2)

(let ((<> 10))
  ((cut-er list 0 <> <...>) 1 2))
; => (0 1 2)

cut-sc3はleque氏の実装．
https://t.co/E8bXvqzYeI

testはMIT/GNU Scheme microcode 15.3でテスト．