Chez Scheme Setup

October 3, 2017

(define (tangle . args)
  (define (parse-line line)
    (let* ((start (string-index line "" (+ start 2)) #f)))
      (if (and start end)
          (values (substring line 0 start)
                  (substring line (+ start 2) end)
                  (substring line (+ end 2) (string-length line)))
          (values line "" ""))))
  (define (named? par)
    (if (null? par)
        (let* ((line (string-trim (car par)))
               (start (string-index line "=" (+ start 2)) #f)))
          (and start end (zero? start)
               (= end (- (string-length line) 3))))))
  (define (unnamed? par)
    (if (null? par)
        (let ((line (string-trim (car par))))
          (and (not (string=? "" line))
               (or (char=? #\; (string-ref line 0))
                   (char=? #\( (string-ref line 0)))))))
  (define (open-input port-or-file . ext)
    (cond ((input-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (open-input-file port-or-file))
          ((and (pair? ext)
                (file-exists? (string-append port-or-file (car ext))))
            (open-input-file (string-append port-or-file (car ext))))
          (else (error (string-append "can't open " port-or-file)))))
  (define (open-output port-or-file . ext)
    (cond ((output-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (delete-file port-or-file)
            (open-output-file port-or-file))
          ((null? ext) (open-output-file port-or-file))
          ((file-exists? (string-append port-or-file (car ext)))
            (delete-file (string-append port-or-file (car ext)))
            (open-output-file (string-append port-or-file (car ext))))
          (else (open-output-file
                  (string-append port-or-file (car ext))))))
  (define (string-trim-left s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s 0))
            (string-trim-left (substring s 1 (string-length s))))
          (else s)))
  (define (string-trim-right s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s (- (string-length s) 1)))
            (string-trim-right (substring s 0 (- (string-length s) 1))))
          (else s)))
  (define (string-trim s) (string-trim-left (string-trim-right s)))
  (define (string-index search target start)
    (let ((search-len (string-length search))
          (target-len (string-length target)))
      (let loop ((k start))
        (cond ((string (reverse line))))
              ((char=? #\newline c)
                (eat #\return p) (list->string (reverse line)))
              ((char=? #\return c)
                (eat #\newline p) (list->string (reverse line)))
              (else (loop (read-char p) (cons c line)))))))
  (define (read-par p)
    (define (get-non-blank-line p)
      (let blank ((s (read-line p)))
        (if (and (not (eof-object? s)) (string=? "" s))
            (blank (read-line p))
    (let par ((s (get-non-blank-line p)) (ls '()))
      (if (or (eof-object? s) (string=? "" s))
          (reverse ls)
          (par (read-line p) (cons s ls)))))
  (define (tangl name dict indent output)
    (let loop ((lines (cdr (assoc name dict))))
        (lambda () (parse-line (car lines)))
        (lambda (prefix call-name suffix)
          (display prefix output)
          (if (and (not (string=? "" call-name))
                   (assoc call-name dict))
              (tangl call-name
                     (make-string (+ (string-length indent)
                                     (string-length prefix))
          (cond ((not (string=? "" suffix))
                  (loop (cons suffix (cdr lines))))
                ((pair? (cdr lines))
                  (newline output)
                  (display indent output)
                  (loop (cdr lines))))))))
  (define (build input)
    (let loop ((par (read-par input)) (dict '()))
      (cond ((null? par) dict)
            ((unnamed? par) (loop (read-par input) (add-dict "" dict par)))
            ((named? par) (loop (read-par input)
                                (add-dict (get-name par) dict (cdr par))))
            (else (loop (read-par input) dict)))))
  (define (get-name par)
    (let* ((line (car par))
           (start (string-index line "=" (+ start 2))))
      (substring line (+ start 2) end)))
  (define (add-dict name dict lines)
    (if (null? dict)
        (cons (cons name (dedent lines)) dict)
        (let loop ((item (car dict)) (unscanned (cdr dict)) (scanned '()))
          (cond ((string=? (car item) name)
                  (cons (append item (dedent lines))
                        (append unscanned (reverse scanned))))
                ((null? unscanned)
                  (cons (cons name (dedent lines))
                        (cons item (reverse scanned))))
                (else (loop (car unscanned) (cdr unscanned)
                            (cons item scanned)))))))
  (define (dedent ls)
    (define (all xs)
      (or (null? xs)
          (and (car xs)
               (all (cdr xs)))))
    (cond ((null? ls) ls)
          ((null? (cdr ls)) (list (string-trim-left (car ls))))
          ((and (< 1 (length ls))
           (all (map (lambda (s) (positive? (string-length s))) ls))
           (char-whitespace? (string-ref (car ls) 0))
           (apply char=? (map (lambda (s) (string-ref s 0)) ls)))
             (dedent (map (lambda (s) (substring s 1 (string-length s)))
          (else ls)))
  (let ((i (open-input (if (pair? args) (car args)
                         (current-input-port)) ".lss"))
        (o (open-output-string)))
    (let ((dict (build i)))
      (if (pair? dict)
            (tangl "" dict "" o)
            (close-input-port i)
            (let ((s (get-output-string o)))
              (close-output-port o)
              (if (and (pair? args) (pair? (cdr args)))
                  (let ((o (open-output (cadr args) ".ss")))
                    (display s o)
                    (close-output-port o)))

Pages: 1 2 3 4 5 6 7 8 9 10

3 Responses to “Chez Scheme Setup”

  1. programmingpraxis said

    My apologies; the formatting got really messed up. I’ll work on fixing through the day today.

  2. chaw said

    I think the pairing heap implementation will not scale to beyond stack limits since it uses non-tail recursion. An easy fix would be to replace the recursive calls in pq-merge-pairs with a fold of pq-merge on pre-paired arguments.

  3. […] There are several pattern-matching libraries available for Scheme, but they are rather heavy (the one I use, by Friedman, Hilsdale and Dybvig, is over six hundred lines of code). Our Standard Prelude has a […]

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: