check-who.rkt

#lang racket/base

(require racket/include
         racket/stxparam
         (for-syntax racket/base syntax/parse/pre))

(provide
 quote
 #%datum
 (rename-out [include |#include|]
             [-define define]
             [-define define/who]
             [-define-syntax define-syntax]
             [-lambda lambda]
             [-case-lambda case-lambda]
             [-let let]
             [-let let*]
             [-let letrec]
             [literal-app #%app]
             [free-id #%top]
             [#%plain-module-begin #%module-begin]))

(define-syntax (literal-app stx)
  (syntax-parse stx
    [(_)
     (syntax/loc stx '())]
    [(_ fun arg ...)
     (syntax/loc stx
       (#%plain-app list fun arg ...))]))

(define-syntax-parameter current-ctxt "unknown")

(define-for-syntax (no-direct-app stx)
  (syntax-parse stx
    [_:id (syntax/loc stx 'id)]
    [(form arg ...)
     #:with loc (format "~a:~a:~a"
                        (car (regexp-match #rx"racket\\/src\\/cs.*$" (syntax-source stx)))
                        (syntax-line stx)
                        (syntax-column stx))
     #:with ctxt (syntax-parameter-value #'current-ctxt)
     (syntax/loc stx
       (begin
         (printf "~a: ~s\n in: ~a\n" 'loc '(form arg ...) 'ctxt)
         (list 'form arg ...)))]))

(define-syntax (free-id stx) (quasisyntax/loc stx '#,(cdr (syntax-e stx))))

(begin-for-syntax
  (define-syntax-class formals
    #:attributes ([arg 1])
    (pattern var-arg:id
      #:with (arg ...) #'(var-arg))
    (pattern (arg:id ...))
    (pattern (arg-init:id ... . arg-rest:id)
      #:with (arg ...) #'(arg-init ... arg-rest))))

(define-syntax (-define stx)
  (syntax-parse stx
    [(form (name:id . args:formals) body ...)
     (syntax/loc stx
       (syntax-parameterize ([current-ctxt (format "(~a ~a ...)"
                                                   (syntax-e #'form)
                                                   (map syntax-e (syntax-e #'(name args.arg ...))))])
         (list 'form (cons 'name 'args)
               (let-syntax ([args.arg no-direct-app] ...)
                 body ...))))]
    [_ (quasisyntax/loc stx '#,stx)]))

(define-syntax (-define-syntax orig-stx)
  (with-syntax ([stx orig-stx])
    (syntax/loc orig-stx
      'stx)))

(define-syntax (-lambda stx)
  (syntax-parse stx
    [(_ args:formals body ...+)
     (syntax/loc stx
       (list 'lambda 'args
             (let-syntax ([args.arg no-direct-app] ...)
               body ...)))]))

(define-syntax (-case-lambda stx)
  (syntax-parse stx
    [(_ [args:formals body ...] ...)
     (syntax/loc stx
       (list 'case-lambda
             [list 'args
                   (let-syntax ([args.arg no-direct-app] ...)
                     body ...)] ...))]))

(define-syntax (-let stx)
  (syntax-parse stx
    [(form (~optional rec:id) ([lhs:id rhs] ...) body ...)
     (syntax/loc stx
       (list 'form (~? 'rec) (list [list 'lhs rhs] ...)
             body ...))]))

do-check.rkt

#lang racket/base

(require (for-syntax racket/base syntax/parse/pre))


(define-syntax (check-modules stx)
  (syntax-parse stx
    [(_ mod ...)
     #:with (mod-str ...) (for/list ([mod (in-list (syntax-e #'(mod ...)))])
                            (symbol->string (syntax-e mod)))
     (syntax/loc stx
       (begin
         (module mod "check-who.rkt" (|#include| mod-str)) ...
         (require 'mod ...)))]))

(check-modules
absify.ss
c/convert-to-boot.ss
c/cross-serve.ss
c/mk-cross-serve.ss
c/same-boot.ss
c/to-pbchunk.ss
c/to-vfasl.ss
chezpart.sls
compile-file.ss
expander.sls
expander/env.ss
include.ss
; io.sls
io/terminal.ss
; linklet.sls
linklet/annotation.ss
linklet/check.ss
linklet/compress.ss
linklet/config.ss
linklet/cross-compile.ss
linklet/performance.ss
linklet/read.ss
linklet/version.ss
; linklet/write.ss
main/help.ss
; place-register.ss
primitive/extfl.ss
primitive/flfxnum.ss
primitive/foreign.ss
primitive/futures.ss
primitive/internal.ss
primitive/kernel.ss
primitive/linklet.ss
primitive/network.ss
primitive/paramz.ss
primitive/place.ss
primitive/terminal.ss
primitive/unsafe.ss
regexp.sls
; rumble.sls
rumble/arity.ss
rumble/async-callback.ss
; rumble/begin0.ss
rumble/boolean.ss
; rumble/box.ss       ;; err
; rumble/bytes.ss
rumble/char-range.ss
; rumble/char.ss ;; err
; rumble/check.ss ;; err arg
; rumble/constant.ss ;; err
rumble/control.ss
rumble/correlated.ss
rumble/datum.ss
rumble/engine.ss
; rumble/ephemeron.ss ;; err
rumble/equal.ss
rumble/errno-data.ss
rumble/error-adjuster.ss
rumble/error-rewrite.ss
rumble/error.ss
rumble/extfl.ss
; rumble/flvector.ss ;; err
; rumble/foreign.ss ;; err
rumble/fsemaphore.ss
rumble/future.ss
rumble/graph.ss
rumble/hamt-stencil.ss
rumble/hamt-vector.ss
; rumble/hash-code.ss ;; err
; rumble/hash.ss ;; err
rumble/immutable.ss
rumble/impersonator.ss
; rumble/inline.ss ;; err
rumble/interrupt.ss
rumble/intmap.ss
rumble/keyword.ss
rumble/list.ss
rumble/lock.ss
; rumble/memory.ss ;; err #!bwp -> #lang?
rumble/mpair.ss
rumble/name.ss
; rumble/number.ss ;; err
rumble/object-name.ss
rumble/parameter.ss
rumble/patricia.ss
rumble/place.ss
rumble/prefab.ss
; rumble/procedure.ss ;; err
rumble/pthread.ss
rumble/random.ss
rumble/source.ss
rumble/srcloc.ss
; rumble/string.ss ;; err
; rumble/struct.ss ;; err #!base-rtd
rumble/symbol.ss
rumble/syntax-rule.ss
rumble/system.ss
rumble/thread-cell.ss
rumble/thread-local.ss
rumble/time.ss
; rumble/unsafe.ss
rumble/value.ss
rumble/variable.ss
; rumble/vector.ss ;; err
rumble/version.ss
rumble/virtual-register.ss
; rumble/will-executor.ss ;; err !bwp
schemify.sls
strip.ss
; thread.sls ;; err app rest
)

equal-rec.rkt

#lang racket/base

(struct s (x) #:property prop:procedure 0)
(equal?/recur 5 3 (s (lambda (x y) #t))) ;; ok

(equal?/recur (cons 1 2) (cons 1 2) (s (lambda (x y) #t)))
(equal?/recur (vector 1) (vector 1) (s (lambda (x y) #t)))
(equal?/recur (box 0) (box 0) (s (lambda (x y) #t)))

(equal-always?/recur '(1 . 2) '(1 . 2) (s (lambda (x y) #t)))
(equal-always?/recur '#(0) '#(0) (s (lambda (x y) #t)))
(equal-always?/recur '#&0 '#&0 (s (lambda (x y) #t)))