source: project/release/3/cmk/cmk-utils.scm @ 12843

;; from srfi-1

;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
;;; (cons* a1) = a1     (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
;;;
;;; (cons first (unfold not-pair? car cdr rest values))

(define (cons* first . rest)
  (let recur ((x first) (rest rest))
    (if (pair? rest)
        (cons x (recur (car rest) (cdr rest)))
        x)))

(define (every pred lis1)
;  (check-arg procedure? pred every)
      ;; Fast path
      (or (null-list? lis1)
          (let lp ((head (car lis1))  (tail (cdr lis1)))
            (if (null-list? tail)
                (pred head)     ; Last PRED app is tail call.
                (and (pred head) (lp (car tail) (cdr tail)))))))

(define (any pred lis1)

      ;; Fast path
      (and (not (null-list? lis1))
           (let lp ((head (car lis1)) (tail (cdr lis1)))
             (if (null-list? tail)
                 (pred head)            ; Last PRED app is tail call.
                 (or (pred head) (lp (car tail) (cdr tail)))))))


;; This FILTER shares the longest tail of L that has no deleted elements.
;; If Scheme had multi-continuation calls, they could be made more efficient.

(define (filter pred lis)                       ; Sleazing with EQ? makes this
;  (check-arg procedure? pred filter)           ; one faster.
  (let recur ((lis lis))                
    (if (null-list? lis) lis                    ; Use NOT-PAIR? to handle dotted lists.
        (let ((head (car lis))
              (tail (cdr lis)))
          (if (pred head)
              (let ((new-tail (recur tail)))    ; Replicate the RECUR call so
                (if (eq? tail new-tail) lis
                    (cons head new-tail)))
              (recur tail))))))                 ; this one can be a tail call.


;;; Map F across L, and save up all the non-false results.
(define (filter-map f lis1)
  ;; Fast path.
  (let recur ((lis lis1))
    (if (null-list? lis) lis
        (let ((tail (recur (cdr lis))))
          (cond ((f (car lis)) => (lambda (x) (cons x tail)))
                (else tail))))))


;; end srfi-1

;; from srfi-13 

;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
;;; strings, which they concatenate into a result string. STRING-CONCATENATE
;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
;;; not) return a result that shares storage with any of its arguments. In
;;; particular, if it is applied to a singleton list, it is permitted to
;;; return the car of that list as its value.


;;; Here it is written out. I avoid using REDUCE to add up string lengths
;;; to avoid non-R5RS dependencies.
(define (string-concatenate strings)
  (let* ((total (do ((strings strings (cdr strings))
                     (i 0 (+ i (string-length (car strings)))))
                    ((not (pair? strings)) i)))
         (ans (make-string total)))
    (let lp ((i 0) (strings strings))
      (if (pair? strings)
          (let* ((s (car strings))
                 (slen (string-length s)))
            (%string-copy! ans i s 0 slen)
            (lp (+ i slen) (cdr strings)))))
    ans))
          
;; end srfi-13

(define (s+ . lst)    (string-concatenate (map ->string lst)))
(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
(define nl "\n")

(define ($ x) (if (string? x) (string->symbol x) x))

(define (pcmd$ p x) 
  (if p (string->symbol (string-append (map ->string (list p "-" x))))
      (string->symbol (->string x))))

(define (lookup-def k lst . rest)
  (let-optionals rest ((default #f))
      (let ((kv (assoc k lst)))
        (if (not kv) default
            (match kv ((k v) v) (else (cdr kv)))))))

(define (pv p . rest)
  (let ((v (p)))
    (if (procedure? v) (apply v rest) 
        v)))



;; Code from unit posix

(define current-directory
  (let ([make-string make-string])
    (lambda (#!optional dir)
      (if dir
          (change-directory dir)
          (let* ([buffer (make-string 256)]
                 [len (##core#inline "C_curdir" buffer)] )
            (##sys#update-errno)
            (if len
                (##sys#substring buffer 0 len)
                (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )


(define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
(define (badmode m) (##sys#error "illegal input/output mode specifier" m))

(define (check cmd inp r)
  (##sys#update-errno)
  (if (##sys#null-pointer? r)
      (##sys#signal-hook #:file-error "cannot open pipe" cmd)
      (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
        (##core#inline "C_set_file_ptr" port r)
        port) ) )

(define (open-input-pipe cmd . m)
  (##sys#check-string cmd 'open-input-pipe)
  (let ([m (mode m)])
    (check
     cmd #t
     (case m
       ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
       ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
       (else (badmode m))))))

(define (close-input-pipe port)
  (lambda (port)
    (##sys#check-port port 'close-input-pipe)
    (let ((r (##core#inline "close_pipe" port)))
      (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
      r) ) )

(define with-input-from-pipe
    (lambda (cmd thunk . mode)
      (let ([old ##sys#standard-input]
            [p (apply open-input-pipe cmd mode)] )
        (set! ##sys#standard-input p)
        (##sys#call-with-values thunk
          (lambda results
            (close-input-pipe p)
            (set! ##sys#standard-input old)
            (apply values results) ) ) ) ) )


(define (##sys#stat file link loc)
  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
                 [(string? file)
                  (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
                    (if link
                        (##core#inline "C_lstat" path)
                        (##core#inline "C_stat" path) ) ) ]
                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
    (when (fx< r 0)
      (posix-error #:file-error loc "cannot access file" file) ) ) )

(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")

(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
(define (file-modification-time f) (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)


;; End code from unit posix

;; Code from unit files

(define (chop-pds str pds)
  (and str
       (let ((len (##sys#size str))
             (pdslen (if pds (##sys#size pds) 1)))
         (if (and (fx>= len 1)
                  (if pds
                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
                            '(#\/ #\\) ) ) )
             (##sys#substring str 0 (fx- len pdslen))
             str) ) ) )

(define make-pathname)

(let ([string-append string-append]
      [absolute-pathname? absolute-pathname?]
      [def-pds "/"] )

  (define (conc-dirs dirs pds)
    (##sys#check-list dirs 'make-pathname)
    (let loop ([strs dirs])
      (if (null? strs)
          ""
          (let ((s1 (car strs)))
            (if (zero? (string-length s1))
                (loop (cdr strs))
                (string-append 
                 (chop-pds (car strs) pds)
                 (or pds def-pds)
                 (loop (cdr strs))) ) ) ) ) )

  (define (canonicalize-dirs dirs pds)
    (cond [(or (not dirs) (null? dirs)) ""]
          [(string? dirs) (conc-dirs (list dirs) pds)]
          [else           (conc-dirs dirs pds)] ) )

  (define (_make-pathname loc dir file ext pds)
    (let ([ext (or ext "")]
          [file (or file "")]
          [pdslen (if pds (##sys#size pds) 1)] )
      (##sys#check-string dir loc)
      (##sys#check-string file loc)
      (##sys#check-string ext loc)
      (when pds (##sys#check-string pds loc))
      (string-append
       dir
       (if (and (fx>= (##sys#size file) pdslen)
                (if pds
                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
           (##sys#substring file pdslen (##sys#size file))
           file)
       (if (and (fx> (##sys#size ext) 0)
                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
           "."
           "")
       ext) ) )

  (set! make-pathname
    (lambda (dirs file #!optional ext pds)
      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
  )

;; end code from unit files


;;; Like `system', but allows format-string and bombs on nonzero return code:

(define system*
  (let ([sprintf sprintf]
        [system system] )
    (lambda (fstr . args)
      (let* ([str (apply sprintf fstr args)]
             [n (system str)] )
        (unless (zero? n)
          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )

(define (run:execute explist)
  (define (smooth lst)
    (let ((slst (map ->string lst)))
      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
  (for-each
   (lambda (cmd)
     (when (run-verbose) (printf "  ~A~%~!" cmd))
     (system* "~a" cmd) )
   (map smooth explist) ) )

(define-macro (run . explist)
  `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )


(define (run:execute* explist)
  (define (smooth lst)
    (let ((slst (map ->string lst)))
      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
  (for-each
   (lambda (cmd)
     (when (run-verbose) (printf "  ~A~%~!" cmd))
     (system (sprintf "~a" cmd)) )
   (map smooth explist) ) )

(define-macro (run* . explist)
  `(run:execute* (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )


(define (ipipe:execute lam cmd)
  (define (smooth lst)
    (let ((slst (map ->string lst)))
      (string-intersperse (cons (car slst) (cdr slst)) " ")))
  ((lambda (cmd) 
     (when (run-verbose) (printf "  ~A~%~!" cmd))
     (with-input-from-pipe (sprintf "~a" cmd) lam))
   (smooth cmd)))

(define-macro (ipipe lam . explist)
  `(ipipe:execute ,lam ,@(map (lambda (x) (list 'quasiquote x)) explist)))



;;; "make" functionality from chicken-setup

(define (make:find-matching-line str spec)
  (let ((match? (lambda (s) (string=? s str))))
    (let loop ((lines spec))
      (cond
       ((null? lines) #f)
       (else (let* ((line (car lines))
                    (names (if (string? (car line))
                               (list (car line))
                               (car line))))
               (if (any match? names)
                   line
                   (loop (cdr lines)))))))))

(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))

(define (make:check-spec spec)
  (and (or (list? spec) (make:form-error "specification is not a list" spec))
       (or (pair? spec) (make:form-error "specification is an empty list" spec))
       (every
        (lambda (line)
          (and (or (and (list? line) (<= 2 (length line) 3))
                   (make:form-error "list is not a list with 2 or 3 parts" line))
               (or (or (string? (car line))
                       (and (list? (car line))
                            (every string? (car line))))
                   (make:form-error "line does not start with a string or list of strings" line))
               (let ((name (car line)))
                 (or (list? (cadr line))
                     (make:line-error "second part of line is not a list" (cadr line) name)
                     (every (lambda (dep)
                               (or (string? dep)
                                   (make:form-error "dependency item is not a string" dep)))
                             (cadr line)))
                 (or (null? (cddr line))
                     (procedure? (caddr line))
                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
        spec)))

(define (make:check-argv argv)
  (or (string? argv)
      (every string? argv)
      (error "argument is not a string or string list" argv)))


(define (make:make/proc/helper spec argv)
  (when (vector? argv) (set! argv (vector->list argv)))
  (make:check-spec spec)
  (make:check-argv argv)
  (letrec ((made '())
           (exn? (condition-predicate 'exn))
           (exn-message (condition-property-accessor 'exn 'message))
           (make-file
            (lambda (s indent)
              (let* ((line (make:find-matching-line s spec))
                     (date (and (file-exists? s)
                                (file-modification-time s))))
                (when (run-verbose)
                  (printf "make: ~achecking ~a~%" indent s))
                (if line
                    (let ((deps (cadr line)))
                      (for-each (let ((new-indent (string-append " " indent)))
                                  (lambda (d) (make-file d new-indent)))
                                deps)
                      (let ((reason
                             (or (not date)
                                 (any (lambda (dep)
                                        (unless (file-exists? dep)
                                          (error (sprintf "dependency ~a was not made~%" dep)))
                                        (and (> (file-modification-time dep) date)
                                             dep)) 
                                        deps))))
                        (when reason
                          (let ((l (cddr line)))
                            (unless (null? l)
                              (set! made (cons s made))
                              (when (run-verbose)
                                (printf "make: ~amaking ~a~a~%"
                                        indent
                                        s
                                        (cond
                                         ((not date)
                                          (string-append " because " s " does not exist"))
                                         ((string? reason)
                                          (string-append " because " reason " changed"))
                                         (else
                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
                                                                  reason date)))) ) )
                              (handle-exceptions exn
                                  (begin
                                    (printf "make: Failed to make ~a: ~a~%"
                                            (car line)
                                            (if (exn? exn)
                                                (exn-message exn)
                                                exn))
                                    (signal exn) )
                                ((car l))))))))
                    (unless date
                      (error (sprintf "don't know how to make ~a" s))))))))
    (cond
     ((string? argv) (make-file argv ""))
     ((null? argv) (make-file (caar spec) ""))
     (else (for-each (lambda (f) (make-file f "")) argv)))
    (when (run-verbose)
      (for-each (lambda (item)
                  (printf "make: made ~a~%" item))
        (reverse made)))) )

(define make/proc
  (case-lambda
   ((spec) (make:make/proc/helper spec '()))
   ((spec argv)
    (make:make/proc/helper
     spec
     (if (vector? argv)
         (vector->list argv)
         argv) ) ) ) )

;; end make procedures