;; basescheme.ss ;; ;; @author Morgan McGuire, morgan@cs.brown.edu ;; ;; @created 2002-01-15 ;; @edited 2002-01-15 ;; ;; Basic Scheme environment used for the foolproofscheme transformation ;; environment. Don't require directly; use foolproofscheme. ;; (module basescheme mzscheme (require (lib "unitsig.ss") (lib "url.ss" "net") (lib "string.ss") (lib "list.ss") (lib "etc.ss") (lib "base64.ss" "net") (lib "file.ss") (lib "pretty.ss")) (require-for-syntax (lib "list.ss")) (provide (all-from (lib "list.ss")) (all-from (lib "string.ss")) (all-from (lib "file.ss")) (all-from (lib "pretty.ss")) (all-from mzscheme) define-macro reparse-for-colons retokenize-for-colons symbol-remove-first string-index print-to-string neq? proc?) (define (neq? a b) (not (eq? a b))) (define proc? procedure?) (define (print-to-string x) (let* ([out (open-output-string)] [result (begin (print x out) (get-output-string out))]) (close-output-port out) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define-macro like the one that was in 1.0 PLT Scheme; ;; allows you to directly walk the parse tree. ;; ;; This is needed for proc. (define-syntax define-macro (syntax-rules () [(_ (macro-name arg) m1 m2 ...) (define-syntax (macro-name expr) (syntax-case expr () ;; () = no keywords to match against [(_ body1 body2 (... ...)) ;; always use _ for keyword position (datum->syntax-object expr ((lambda (arg) m1 m2 ...) (syntax-object->datum (syntax (body1 body2 (... ...))))) expr expr)])) ])) ;(define-syntax define-macro ; (syntax-rules ; () ; [(_ (macro-name arg) m1 m2 ...) ; ; ; (define-syntax (macro-name expr) ; (syntax-case expr () ;; () = no keywords to match against ; [(_ body1 body2 (... ...)) ;; always use _ for keyword position ; (datum->syntax-object ; expr ; ( ; ; (lambda (arg) m1 m2 ...) ; ; (syntax-object->datum ; (syntax (body1 body2 (... ...))))))])) ; ; ])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Removes the first character from a symbol ;; ;; symbol -> symbol (define (symbol-remove-first x) (let ([y (symbol->string x)]) (string->symbol (substring y 1 (string-length y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Returns the first index of char in str, ;; false if it does not appear. ;; ;; str x char => int (define (string-index str char) (if (not (string? str)) (error "First argument must be a string")) (let ([index 0] [length (string-length str)]) ;; manually expanded while loop (letrec ([test? (lambda () (and (< index length) (not (equal? (string-ref str index) char))))] [body (lambda () (if (test?) (begin (set! index (+ index 1)) (body)) void))]) (body)) (if (= index length) #f index))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Returns a list of one or more symbols where tokens have been ;; re-broken at colons. Called by retokenize-for-colons. ;; ;; Does not attempt to break symbols that begin with "exn:" plus one ;; character because MzScheme uses variables with colons in them for ;; exceptions. ;; ;; symbol-> (list symbol) (define (break-symbol-at-colon sym) (let* ([str (symbol->string sym)] [len (string-length str)]) (if (and (>= len 5) (string=? (substring str 0 4) "exn:")) ;; Just return the symbol; we don't try to break "exn:..." sym (let ([index (string-index str #\:)]) (if index (let ([result '(:)]) (if (> index 0) (set! result (cons (string->symbol (substring str 0 index)) result))) (if (< index (- len 1)) (set! result (append result (list (string->symbol (substring str (+ index 1) len)))))) result) (list sym)))))) ;; Finds all instances of the pattern x : y and ;; changes them to (: x y) in a new expression. ;; ;; list => list (define (reparse-for-colons expr) (cond ;; Empty list; just return [(eq? expr '()) expr] ;; Last arg; just return [(empty? (rest expr)) expr] ;; Look ahead 1 token for a colon. If there is one ;; form the nested (: var type) and recurse on the ;; rest of the list. [(eq? (second expr) ':) `((: ,(first expr) ,(third expr)) ,@(reparse-for-colons (cdddr expr)))] ;; This argument does not have a type; proceed on to the ;; rest. [else (cons (first expr) (reparse-for-colons (rest expr)))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Finds all instances of the pattern x:y and breaks them into x : y ;; in a new expression. ;; ;; list => list (define (retokenize-for-colons expr) (cond ;; Out of tokens, return [(eq? expr '()) expr] ;; The first token is a symbol; see if it has a colon in it [(symbol? (first expr)) (append (break-symbol-at-colon (first expr)) (retokenize-for-colons (cdr expr)))] [else (append (list (first expr)) (retokenize-for-colons (cdr expr)))])) ) ; end of module