[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: question on the opaque syntax object debate



Andre van Tonder wrote:
On Thu, 18 Aug 2005, Andrew Wilcox wrote:

Thus my question is: does PLT Scheme have syntax location features
that this SRFI proposal is not able to provide?

There is one that it would in principle be able to provide but chooses not to: The SRFI proposal requires the first argument of datum->syntax-object to be an identifier, as indeed Chez does, while PLT allows an arbitrary syntax object there.

There is no fundamental reason why this cannot be supported, but it would make the reference implementation more complex. Also, I don't know how useful this feature really is in practice.

Attached below is an example, in which I used it. The function substitute-<>-with-name makes a recursive decent on a syntax-object
and replaces <> with fresh names. Quasisyntax/loc (which is
implemented using datum->syntax-object) is used to keep the
properties of the original syntax.

/Jens Axel
;;; deep-cut.ss  --  Jens Axel Soegaard

; This file implementes a generalized version of cut from srfi-26.

;  The macro cut transforms a <cut-expression> into a <lambda expression> 
;  with as many formal variables as there are slots in the list <slot-or-expr>*. 
;  The body of the resulting <lambda expression> calls the first <slot-or-expr> 
;  with arguments from <slot-or-expr>* in the order they appear. In case there 
;  is a rest-slot symbol, the resulting procedure is also of variable arity, 
;  and the body calls the first <slot-or-expr> with all arguments provided to 
;  the actual call of the specialized procedure.

; <cut-expression> -->  (cut <slot-or-expr> <slot-or-expr>*) 
;                   |   (cut <slot-or-expr> <slot-or-expr>* <...>) ; with "rest-slot" 
;                   |   (cute <slot-or-expr> <slot-or-expr>*) ; evaluate non-slots at specialization time 
;                   |   (cute <slot-or-expr> <slot-or-expr>* <...>) ; with "rest-slot" 

; <slot-or-expr>   -->  <>; a "slot" 
;                   |   <expression>; a "non-slot expression" 

(module cut mzscheme
  
  (provide cut)
  
  (define-for-syntax (fresh-name)
    (car (generate-temporaries #'(cut))))
  
  (define-for-syntax (substitute-<>-with-name expr)
    (syntax-case expr (<>)
      [<>       (let ((name (fresh-name)))
                  (values (list name) name))]
      [(a . d)  (let-values ([(a-names a-expr) (substitute-<>-with-name #'a)]
                             [(d-names d-expr) (substitute-<>-with-name #'d)])
                  (values (append a-names d-names)
                          (quasisyntax/loc expr
                            (#,a-expr . #,d-expr))))]
      [_        (values '() expr)]))
  
  
  ; generate-names/exprs : 
  ;    Given the arguments for the macro call to cut as a syntax-list,
  ;  call build with two lists:
  ;    1) a list of names given to each <>-slot
  ;    2) [cut] a list of the macro arguments, except that all occurences 
  ;       of a <>-slots have been substituted with the chosen name.
  (define-for-syntax (generate-names/exprs slot-or-exprs build)
    (let loop ([slot-or-exprs   (syntax->list slot-or-exprs)]
               [slot-names      '()]
               [names-or-exprs  '()])
      (cond
        [(null? slot-or-exprs)  (build (reverse slot-names)
                                       (reverse names-or-exprs))]
        [else                   (let-values ([(names substituted-expr)
                                              (substitute-<>-with-name (car slot-or-exprs))])
                                  (loop (cdr slot-or-exprs)
                                        (append (reverse names) slot-names)
                                        (cons substituted-expr names-or-exprs)))])))
  
  (require-for-syntax (lib "name.ss" "syntax"))
  
  (define-for-syntax (make-inferred-cut-name stx)
    (cond
      [(identifier? stx)                       (string->symbol
                                                (string-append
                                                 "specialized version of "
                                                 (symbol->string (syntax-e stx))
                                                 " originating from a cut"))]
      [(syntax-property stx 'inferred-name) => (lambda (name)
                                                 (string->symbol
                                                  (string-append
                                                   "specialized version of "
                                                   (symbol->string name)
                                                   " originating from a cut")))]
      [else                                     #f]))
  
  (define-for-syntax (set-inferred-name stx name)
    (if name
        (syntax-property stx 'inferred-name name)
        stx))
  
  (define-syntax (cut stx)
    (syntax-case stx (<> <...>)
      [(cut)
       (raise-syntax-error #f "cut expects 1 or more slots or expressions, given none"  stx)]
      [(cut <>)
       (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
      [(cut proc)
       (set-inferred-name 
        #`(lambda () #,(syntax/loc stx (proc)))
        (make-inferred-cut-name #'proc))]
      [(cut <> slot-or-expr ...)
       (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
      [(cut <...> slot-or-expr ...)
       (raise-syntax-error #f "cut expects an expression at the first position, given <...>" stx)]
      [(cut proc slot-or-expr ... <...>)
       ;   Applying a wrong number of arguments to the the lamba generated by cut, will provoke an
       ; error caused by the application (proc ...). The quasisyntax/loc makes sure DrScheme
       ; shows the cut-expression as the source of the error in stead of showing an error in 
       ; the code implementing the macro i.e. in this code.
       ;   Note: Is it possible to propagate the error to the location of the wrong application
       ;         in the user code?
       (generate-names/exprs #'(slot-or-expr ...)
                             (lambda (slot-names names-or-exprs . ignored)
                               #`(lambda (#,@slot-names . xs)
                                   #,(quasisyntax/loc stx
                                       (apply proc #,@names-or-exprs xs)))))]
      [(cut proc slot-or-expr ...)
       (generate-names/exprs #'(slot-or-expr ...)
                             (lambda (slot-names names-or-exprs . ignored)
                               #`(lambda #,slot-names
                                   #,(quasisyntax/loc stx
                                       (proc #,@names-or-exprs)))))]))
  
  )

;(require cut)
;> ((cut list '- (list <> (list '- <> <> '-)) (list <>) (list <> (list <> <>))) 2 3 4 5 6 7 8)
;(- (2 (- 3 4 -)) (5) (6 (7 8)))