~ chicken-core (master) /egg-compile.scm

   1;;;; egg-info processing and compilation
   2;
   3; Copyright (c) 2017-2022, The CHICKEN Team
   4; All rights reserved.
   5;
   6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   7; conditions are met:
   8;
   9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  10;     disclaimer.
  11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  12;     disclaimer in the documentation and/or other materials provided with the distribution.
  13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  14;     products derived from this software without specific prior written permission.
  15;
  16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  24; POSSIBILITY OF SUCH DAMAGE.
  25
  26
  27(define default-extension-options '())
  28(define default-program-options '())
  29(define default-static-program-link-options '())
  30(define default-dynamic-program-link-options '())
  31(define default-static-extension-link-options '())
  32(define default-dynamic-extension-link-options '())
  33(define default-static-compilation-options '("-O2" "-d1"))
  34(define default-dynamic-compilation-options '("-O2" "-d1"))
  35(define default-import-library-compilation-options '("-O2" "-d0"))
  36
  37(define default-program-linkage
  38  (if staticbuild '(static) '(dynamic)))
  39
  40(define default-extension-linkage
  41  (if staticbuild '(static) '(static dynamic)))
  42
  43(define +unix-executable-extension+ "")
  44(define +windows-executable-extension+ ".exe")
  45(define +unix-object-extension+ ".o")
  46(define +unix-archive-extension+ ".a")
  47(define +windows-object-extension+ ".obj")
  48(define +windows-archive-extension+ ".a")
  49(define +link-file-extension+ ".link")
  50
  51(define keep-generated-files #f)
  52(define dependency-targets '())
  53
  54
  55;;; some utilities
  56
  57(define override-prefix
  58  (let ((prefix (get-environment-variable "CHICKEN_INSTALL_PREFIX")))
  59    (lambda (dir default)
  60      (if prefix
  61          (string-append prefix dir)
  62          default))))
  63
  64(define (object-extension platform)
  65  (case platform
  66    ((unix) +unix-object-extension+)
  67    ((windows) +windows-object-extension+)))
  68
  69(define (archive-extension platform)
  70  (case platform
  71    ((unix) +unix-archive-extension+)
  72    ((windows) +windows-archive-extension+)))
  73
  74(define (executable-extension platform)
  75  (case platform
  76     ((unix) +unix-executable-extension+)
  77     ((windows) +windows-executable-extension+)))
  78
  79(define (copy-directory-command platform)
  80  "cp -r")
  81
  82(define (copy-file-command platform)
  83  "cp")
  84
  85(define (mkdir-command platform)
  86  "mkdir -p")
  87
  88(define (install-executable-command platform)
  89  (string-append default-install-program " "
  90                 default-install-program-executable-flags))
  91
  92(define (install-file-command platform)
  93  (string-append default-install-program " "
  94                 default-install-program-data-flags))
  95
  96(define (remove-file-command platform)
  97  "rm -f")
  98
  99(define (cd-command platform)
 100  "cd")
 101
 102(define (uses-compiled-import-library? mode)
 103  (not (and (eq? mode 'host) staticbuild)))
 104
 105;; this one overrides "destination-repository" in egg-environment to allow use of
 106;; CHICKEN_INSTALL_PREFIX (via "override-prefix")
 107(define (effective-destination-repository mode #!optional run)
 108   (if (eq? 'target mode)
 109       (if run target-run-repo target-repo)
 110       (or (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")
 111           (override-prefix (string-append "/lib/chicken/" (number->string binary-version))
 112                            host-repo))))
 113
 114;;; topological sort with cycle check
 115
 116(define (sort-dependencies dag eq)
 117  (condition-case (topological-sort dag eq)
 118    ((exn runtime cycle)
 119     (error "cyclic dependencies" dag))))
 120
 121
 122;;; collect import libraries for all modules
 123
 124(define (import-libraries mods dest rtarget mode)
 125  (define (implib name)
 126    (conc dest "/" name ".import."
 127          (if (uses-compiled-import-library? mode)
 128              "so"
 129              "scm")))
 130  (if mods
 131      (map implib mods)
 132      (list (implib rtarget))))
 133
 134
 135;;; normalize target path for "random files" (data, c-include, scheme-include)
 136
 137(define (normalize-destination dest mode)
 138  (let ((dest* (normalize-pathname dest)))
 139    (if (irregex-search '(: bos ".." ("\\/")) dest*)
 140        (error "destination must be relative to CHICKEN install prefix" dest)
 141        (normalize-pathname
 142         (make-pathname (if (eq? mode 'target)
 143                            default-prefix
 144                            (override-prefix "/" host-prefix))
 145                        dest*)))))
 146
 147
 148;;; check condition in conditional clause
 149
 150(define (check-condition tst mode link)
 151  (define (fail x)
 152    (error "invalid conditional expression in `cond-expand' clause"
 153           x))
 154  (let walk ((x tst))
 155    (cond ((and (list? x) (pair? x))
 156           (cond ((and (eq? (car x) 'not) (= 2 (length x)))
 157                  (not (walk (cadr x))))
 158                 ((eq? 'and (car x)) (every walk (cdr x)))
 159                 ((eq? 'or (car x)) (any walk (cdr x)))
 160                 (else (fail x))))
 161          ((memq x '(dynamic static)) (memq x link))
 162          ((memq x '(target host)) (memq x mode))
 163          ((symbol? x) (feature? x))
 164          (else (fail x)))))
 165
 166
 167;;; parse custom configuration information from script
 168
 169(define (parse-custom-config arg)
 170  (define (read-all)
 171    (let loop ((lst '()))
 172      (let ((x (read)))
 173        (if (eof-object? x)
 174            (reverse lst)
 175            (loop (append (reverse (flatten x)) lst))))))
 176  (if (and (list? arg) (eq? 'custom-config (car arg)))
 177      (let* ((arg (cdr arg))
 178             (in (with-input-from-pipe
 179                  (conc default-csi " -s "
 180                        (if (list? arg)
 181                            (string-intersperse (map ->string arg) " ")
 182                            (->string arg)))
 183                  read-all)))
 184        (map ->string in))
 185      (list arg)))
 186
 187
 188;;; compile an egg-information tree into abstract build/install operations
 189
 190(define (compile-egg-info eggfile info version platform mode)
 191  (let ((exts '())
 192        (prgs '())
 193        (objs '())
 194        (data '())
 195        (genfiles '())
 196        (cinc '())
 197        (scminc '())
 198        (target #f)
 199        (src #f)
 200        (files '())
 201        (ifiles '())
 202        (cbuild #f)
 203        (oname #f)
 204        (link '())
 205        (dest #f)
 206        (sdeps '())
 207        (cdeps '())
 208        (lopts '())
 209        (opts '())
 210        (mods #f)
 211        (lobjs '())
 212        (tfile #f)
 213        (ptfile #f)
 214        (ifile #f)
 215        (install #t)
 216        (eggfile (locate-egg-file eggfile))
 217        (objext (object-extension platform))
 218        (arcext (archive-extension platform))
 219        (exeext (executable-extension platform)))
 220    (define (check-target t lst)
 221      (when (member t lst)
 222        (error "target multiply defined" t))
 223      t)
 224    (define (addfiles . filess)
 225      (set! ifiles (concatenate (cons ifiles filess)))
 226      files)
 227    (define (checkfiles files target)
 228      (when (null? files)
 229        (warning "target has no files" target)))
 230    (define (compile-component info)
 231      (case (car info)
 232        ((extension)
 233          (fluid-let ((target (check-target (cadr info) exts))
 234                      (cdeps '())
 235                      (sdeps '())
 236                      (src #f)
 237                      (cbuild #f)
 238                      (link (if (null? link) default-extension-linkage link))
 239                      (tfile #f)
 240                      (ptfile #f)
 241                      (ifile #f)
 242                      (lopts lopts)
 243                      (lobjs '())
 244                      (oname #f)
 245                      (mods #f)
 246                      (opts opts))
 247            (for-each compile-extension/program (cddr info))
 248            (let ((dest (effective-destination-repository mode #t))
 249                  ;; Respect install-name if specified
 250                  (rtarget (or oname target)))
 251              (when (eq? #t tfile) (set! tfile rtarget))
 252              (when (eq? #t ifile) (set! ifile rtarget))
 253              (addfiles
 254                (if (memq 'static link)
 255                    (list (conc dest "/" rtarget
 256                                (if (null? lobjs)
 257                                    objext
 258                                    arcext))
 259                          (conc dest "/" rtarget +link-file-extension+))
 260                    '())
 261                (if (memq 'dynamic link) (list (conc dest "/" rtarget ".so")) '())
 262                (if tfile
 263                    (list (conc dest "/" tfile ".types"))
 264                    '())
 265                (if ifile
 266                    (list (conc dest "/" ifile ".inline"))
 267                    '())
 268                (import-libraries mods dest rtarget mode))
 269              (set! exts
 270                (cons (list target
 271                            dependencies: cdeps
 272                            source: src options: opts
 273                            link-options: lopts linkage: link custom: cbuild
 274                            mode: mode types-file: tfile inline-file: ifile
 275                            predefined-types: ptfile eggfile: eggfile
 276                            modules: (or mods (list rtarget))
 277                            source-dependencies: sdeps
 278                            link-objects: lobjs
 279                            output-file: rtarget)
 280                    exts)))))
 281        ((installed-c-object c-object)
 282          (fluid-let ((target (check-target (cadr info) exts))
 283                      (cdeps '())
 284                      (sdeps '())
 285                      (src #f)
 286                      (cbuild #f)
 287                      (link (if (null? link) default-extension-linkage link))
 288                      (oname #f)
 289                      (mods #f)
 290                      (install (eq? 'installed-c-object (car info)))
 291                      (opts opts))
 292            (for-each compile-extension/program (cddr info))
 293            (let ((dest (effective-destination-repository mode #t))
 294                  ;; Respect install-name if specified
 295                  (rtarget (or oname target)))
 296              (when install
 297                (addfiles (list (conc dest "/" rtarget objext))))
 298              (set! objs
 299                (cons (list target dependencies: cdeps source: src
 300                            options: opts
 301                            linkage: link custom: cbuild
 302                            mode: mode
 303                            eggfile: eggfile
 304                            source-dependencies: sdeps
 305                            output-file: rtarget)
 306                      objs)))))
 307        ((data)
 308          (fluid-let ((target (check-target (cadr info) data))
 309                      (dest #f)
 310                      (files '()))
 311            (for-each compile-data/include (cddr info))
 312            (checkfiles files target)
 313            (let* ((dest (or (and dest (normalize-destination dest mode))
 314                             (if (eq? mode 'target)
 315                                 default-sharedir
 316                                 (override-prefix "/share" host-sharedir))))
 317                   (dest (normalize-pathname (conc dest "/"))))
 318              (addfiles (map (cut conc dest <>) files)))
 319            (set! data
 320              (cons (list target dependencies: '() files: files
 321                          destination: dest mode: mode)
 322                    data))))
 323        ((generated-source-file)
 324          (fluid-let ((target (check-target (cadr info) data))
 325                      (src #f)
 326                      (cbuild #f)
 327                      (sdeps '())
 328                      (cdeps '()))
 329            (for-each compile-extension/program (cddr info))
 330            (unless cbuild
 331              (error "generated source files need a custom build step" target))
 332            (set! genfiles
 333              (cons (list target dependencies: cdeps source: src
 334                          custom: cbuild source-dependencies: sdeps
 335                          eggfile: eggfile)
 336                    genfiles))))
 337        ((c-include)
 338          (fluid-let ((target (check-target (cadr info) cinc))
 339                      (dest #f)
 340                      (files '()))
 341            (for-each compile-data/include (cddr info))
 342            (checkfiles files target)
 343            (let* ((dest (or (and dest (normalize-destination dest mode))
 344                             (if (eq? mode 'target)
 345                                 default-incdir
 346                                 (override-prefix "/include" host-incdir))))
 347                   (dest (normalize-pathname (conc dest "/"))))
 348              (addfiles (map (cut conc dest <>) files)))
 349            (set! cinc
 350              (cons (list target dependencies: '() files: files
 351                          destination: dest mode: mode)
 352                    cinc))))
 353        ((scheme-include)
 354          (fluid-let ((target (check-target (cadr info) scminc))
 355                      (dest #f)
 356                      (files '()))
 357            (checkfiles files target)
 358            (for-each compile-data/include (cddr info))
 359            (let* ((dest (or (and dest (normalize-destination dest mode))
 360                             (if (eq? mode 'target)
 361                                 default-sharedir
 362                                 (override-prefix "/share" host-sharedir))))
 363                   (dest (normalize-pathname (conc dest "/"))))
 364              (addfiles (map (cut conc dest <>) files)))
 365            (set! scminc
 366              (cons (list target dependencies: '() files: files
 367                          destination: dest mode: mode)
 368                    scminc))))
 369        ((program)
 370          (fluid-let ((target (check-target (cadr info) prgs))
 371                      (cdeps '())
 372                      (sdeps '())
 373                      (cbuild #f)
 374                      (src #f)
 375                      (link (if (null? link) default-program-linkage link))
 376                      (lobjs '())
 377                      (lopts lopts)
 378                      (oname #f)
 379                      (opts opts))
 380            (for-each compile-extension/program (cddr info))
 381            (let ((dest (if (eq? mode 'target)
 382                            default-bindir
 383                            (override-prefix "/bin" host-bindir)))
 384                  ;; Respect install-name if specified
 385                  (rtarget (or oname target)))
 386              (addfiles (list (conc dest "/" rtarget exeext)))
 387	      (set! prgs
 388		(cons (list target dependencies: cdeps
 389                            source: src options: opts
 390			    link-options: lopts linkage: link
 391                            custom: cbuild
 392			    mode: mode output-file: rtarget
 393                            source-dependencies: sdeps
 394                            link-objects: lobjs
 395                            eggfile: eggfile)
 396		      prgs)))))
 397        (else (compile-common info compile-component 'component))))
 398    (define (compile-extension/program info)
 399      (case (car info)
 400        ((linkage)
 401         (set! link (cdr info)))
 402        ((types-file)
 403         (set! tfile
 404           (cond ((null? (cdr info)) #t)
 405                 ((not (pair? (cadr info)))
 406                  (arg info 1 name?))
 407                 (else
 408                   (set! ptfile #t)
 409                   (set! tfile
 410                     (or (null? (cdadr info))
 411                         (arg (cadr info) 1 name?)))))))
 412        ((objects)
 413         (let ((los (map ->string (cdr info))))
 414           (set! lobjs (append lobjs los))
 415           (set! cdeps (append cdeps (map ->dep los)))))
 416        ((inline-file)
 417         (set! ifile (or (null? (cdr info)) (arg info 1 name?))))
 418        ((custom-build)
 419         (set! cbuild (->string (arg info 1 name?))))
 420        ((csc-options)
 421         (set! opts
 422           (apply append
 423             opts
 424             (map parse-custom-config (cdr info)))))
 425        ((link-options)
 426         (set! lopts
 427           (apply append
 428             lopts
 429             (map parse-custom-config (cdr info)))))
 430        ((source)
 431         (set! src (->string (arg info 1 name?))))
 432        ((install-name)
 433         (set! oname (->string (arg info 1 name?))))
 434        ((modules)
 435         (set! mods (map library-id (cdr info))))
 436        ((component-dependencies)
 437         (set! cdeps (append cdeps (map ->dep (cdr info)))))
 438        ((source-dependencies)
 439         (set! sdeps (append sdeps (map ->dep (cdr info)))))
 440        (else (compile-common info compile-extension/program 'extension/program))))
 441    (define (compile-common info walk context)
 442      (case (car info)
 443        ((target)
 444         (when (eq? mode 'target)
 445           (for-each walk (cdr info))))
 446        ((host)
 447         (when (eq? mode 'host)
 448           (for-each walk (cdr info))))
 449        ((error)
 450         (apply error (cdr info)))
 451        ((cond-expand)
 452         (compile-cond-expand info walk))
 453        (else
 454          (fprintf (current-error-port) "\nWarning (~a): property `~a' invalid or in wrong context (~a)\n\n" eggfile (car info) context))))
 455    (define (compile-data/include info)
 456      (case (car info)
 457        ((destination)
 458         (set! dest (->string (arg info 1 name?))))
 459        ((files)
 460         (set! files (append files (map ->string (cdr info)))))
 461        (else (compile-common info compile-data/include 'data/include))))
 462    (define (compile-options info)
 463      (define (custom info)
 464        (map parse-custom-config info))
 465      (case (car info)
 466        ((csc-options) (set! opts (apply append opts (custom (cdr info)))))
 467        ((link-options) (set! lopts (apply append lopts (custom (cdr info)))))
 468        ((linkage) (set! link (apply append link (custom (cdr info)))))
 469        (else (error "invalid component-options specification" info))))
 470    (define (compile-cond-expand info walk)
 471      (let loop ((clauses (cdr info)))
 472        (cond ((null? clauses)
 473               (error "no matching clause in `cond-expand' form"
 474                      info))
 475              ((or (eq? 'else (caar clauses))
 476                   (check-condition (caar clauses) mode link))
 477               (for-each walk (cdar clauses)))
 478              (else (loop (cdr clauses))))))
 479    (define (->dep x)
 480      (if (name? x)
 481          (if (symbol? x) x (string->symbol x))
 482          (error "invalid dependency" x)))
 483    (define (compile info)
 484      (case (car info)
 485        ((synopsis dependencies test-dependencies category version author maintainer
 486                   license build-dependencies foreign-dependencies platform
 487                   distribution-files) #f)
 488        ((components) (for-each compile-component (cdr info)))
 489        ((component-options)
 490         (for-each compile-options (cdr info)))
 491        (else (compile-common info compile 'toplevel))))
 492    (define (arg info n #!optional (pred (constantly #t)))
 493      (when (< (length info) n)
 494        (error "missing argument" info n))
 495      (let ((x (list-ref info n)))
 496        (unless (pred x)
 497          (error "argument has invalid type" x))
 498        x))
 499    (define (name? x) (or (string? x) (symbol? x)))
 500    (define dep=? equal?)
 501    (define (filter pred lst)
 502      (cond ((null? lst) '())
 503            ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
 504            (else (filter pred (cdr lst)))))
 505    (define (filter-deps name deps)
 506      (filter (lambda (dep)
 507                (and (symbol? dep)
 508                     (or (assq dep exts)
 509                         (assq dep objs)
 510                         (assq dep data)
 511                         (assq dep cinc)
 512                         (assq dep scminc)
 513                         (assq dep genfiles)
 514                         (assq dep prgs)
 515                         (error "unknown component dependency" dep))))
 516              deps))
 517    ;; collect information
 518    (for-each compile info)
 519    ;; sort topologically, by dependencies
 520    (let* ((all (append prgs exts objs genfiles))
 521           (order (reverse (sort-dependencies
 522                            (map (lambda (dep)
 523                                   (cons (car dep)
 524                                         (filter-deps (car dep)
 525                                                      (get-keyword dependencies: (cdr dep)))))
 526                              all)
 527                            dep=?))))
 528      ;; generate + return build/install commands
 529      (values
 530        ;; build commands
 531        (append-map
 532          (lambda (id)
 533            (cond ((assq id exts) =>
 534                   (lambda (data)
 535                     (let ((link (get-keyword linkage: (cdr data)))
 536                           (mods (get-keyword modules: (cdr data))))
 537                       (append (if (memq 'dynamic link)
 538                                   (list (apply compile-dynamic-extension data))
 539                                   '())
 540                               (if (memq 'static link)
 541                                   ;; if compiling both static + dynamic, override
 542                                   ;; modules/types-file/inline-file properties to
 543                                   ;; avoid generating things twice:
 544                                   (list (apply compile-static-extension
 545                                                (if (memq 'dynamic link)
 546                                                    (cons (car data)
 547                                                          (append '(modules: #f
 548                                                                    types-file: #f
 549                                                                    inline-file: #f)
 550                                                                  (cdr data)))
 551                                                    data)))
 552                                   '())
 553                               (if (uses-compiled-import-library? mode)
 554                                   (map (lambda (mod)
 555                                          (apply compile-import-library
 556                                             mod (cdr data))) ; override name
 557                                     mods)
 558                                   '())))))
 559                  ((assq id prgs) =>
 560                   (lambda (data)
 561                     (let ((link (get-keyword linkage: (cdr data))))
 562                       (append (if (memq 'dynamic link)
 563                                   (list (apply compile-dynamic-program data))
 564                                   '())
 565                               (if (memq 'static link)
 566                                   (list (apply compile-static-program data))
 567                                   '())))))
 568                  ((assq id objs) =>
 569                   (lambda (data)
 570                     (let ((link (get-keyword linkage: (cdr data))))
 571                       (append (if (memq 'dynamic link)
 572                                   (list (apply compile-dynamic-object data))
 573                                   '())
 574                               (if (memq 'static link)
 575                                   (list (apply compile-static-object data))
 576                                   '())))))
 577                  ((assq id genfiles) =>
 578                   (lambda (data)
 579                     (list (apply compile-generated-file data))))
 580                  ((or (assq id data)
 581                       (assq id cinc)
 582                       (assq id scminc))
 583                   '()) ;; nothing to build for data components
 584                  (else (error "Error in chicken-install, don't know how to build component" id))))
 585          order)
 586        ;; installation commands
 587        (append
 588          (append-map
 589            (lambda (ext)
 590              (let ((link (get-keyword linkage: (cdr ext)))
 591                    (mods (get-keyword modules: (cdr ext))))
 592                (append
 593                  (if (memq 'static link)
 594                      (list (apply install-static-extension ext))
 595                      '())
 596                  (if (memq 'dynamic link)
 597                      (list (apply install-dynamic-extension ext))
 598                      '())
 599                  (if (and (memq 'dynamic link)
 600                           (uses-compiled-import-library? (get-keyword mode: ext)))
 601                      (map (lambda (mod)
 602                             (apply install-import-library
 603                                    mod (cdr ext))) ; override name
 604                        mods)
 605                      (map (lambda (mod)
 606                             (apply install-import-library-source
 607                                    mod (cdr ext))) ; s.a.
 608                        mods))
 609                  (if (get-keyword types-file: (cdr ext))
 610                      (list (apply install-types-file ext))
 611                      '())
 612                  (if (get-keyword inline-file: (cdr ext))
 613                      (list (apply install-inline-file ext))
 614                      '()))))
 615             exts)
 616          (map (lambda (obj) (apply install-object obj)) objs)
 617          (map (lambda (prg) (apply install-program prg)) prgs)
 618          (map (lambda (data) (apply install-data data)) data)
 619          (map (lambda (cinc) (apply install-c-include cinc)) cinc)
 620          (map (lambda (scminc) (apply install-data scminc)) scminc))
 621        ;; augmented egg-info
 622        (append `((installed-files ,@ifiles))
 623                (if version `((version ,version)) '())
 624                info)))))
 625
 626
 627;;; shell code generation - build operations
 628
 629(define ((compile-static-extension name #!key mode dependencies
 630                                   source-dependencies
 631                                   source (options '())
 632                                   predefined-types eggfile
 633                                   link-objects modules
 634                                   custom types-file inline-file)
 635         srcdir platform)
 636  (let* ((cmd (or (custom-cmd custom srcdir platform)
 637		  default-csc))
 638         (sname (prefix srcdir name))
 639         (tfile (prefix srcdir (conc types-file ".types")))
 640         (ifile (prefix srcdir (conc inline-file ".inline")))
 641         (lfile (conc sname +link-file-extension+))
 642         (opts (append (if (null? options)
 643                           default-static-compilation-options
 644                           options)
 645                       (if (and types-file
 646                                (not predefined-types))
 647                           (list "-emit-types-file" tfile)
 648                           '())
 649                       (if inline-file
 650                           (list "-emit-inline-file" ifile)
 651                           '())))
 652         (out1 (conc sname ".static"))
 653         (out2 (target-file (conc out1
 654                                  (object-extension platform))
 655                            mode))
 656         (out3 (if (null? link-objects)
 657                   out2
 658                   (target-file (conc out1
 659                                      (archive-extension platform))
 660                                mode)))
 661         (imps (map (lambda (m)
 662                      (prefix srcdir (conc m ".import.scm")))
 663                 (or modules '())))
 664         (targets (append (list out3 lfile)
 665                          (maybe types-file tfile)
 666                          (maybe inline-file ifile)
 667                          imps))
 668         (src (or source (conc name ".scm"))))
 669    (when custom
 670      (prepare-custom-command cmd platform))
 671    (print-build-command targets
 672			 `(,@(filelist srcdir source-dependencies) ,src ,eggfile
 673			   ,@(if custom (list cmd) '())
 674                           ,@(get-dependency-targets dependencies))
 675			 `(,@(if custom '("sh") '())
 676			    ,cmd ,@(if keep-generated-files '("-k") '())
 677				"-regenerate-import-libraries"
 678				,@(if modules '("-J") '()) "-M"
 679				"-setup-mode" "-static" "-I" ,srcdir
 680				"-emit-link-file" ,lfile
 681				,@(if (eq? mode 'host) '("-host") '())
 682				"-D" "compiling-extension"
 683				"-c" "-unit" ,name
 684				"-D" "compiling-static-extension"
 685				"-C" ,(conc "-I" srcdir)
 686				,@opts ,src "-o" ,out2)
 687			 platform)
 688    (when (pair? link-objects)
 689      (let ((lobjs (filelist srcdir
 690                             (map (cut conc <> ".static" (object-extension platform))
 691                               link-objects))))
 692	(print-build-command (list out3)
 693			     `(,out2 ,@lobjs)
 694			     `(,target-librarian ,target-librarian-options ,out3 ,out2 ,@lobjs)
 695			     platform)))
 696    (print-end-command platform)))
 697
 698(define ((compile-dynamic-extension name #!key mode mode dependencies
 699                                    source (options '())
 700                                    (link-options '())
 701                                    predefined-types eggfile
 702                                    link-objects
 703                                    source-dependencies modules
 704                                    custom types-file inline-file)
 705         srcdir platform)
 706  (let* ((cmd (or (custom-cmd custom srcdir platform)
 707                  default-csc))
 708         (sname (prefix srcdir name))
 709         (tfile (prefix srcdir (conc types-file ".types")))
 710         (ifile (prefix srcdir (conc inline-file ".inline")))
 711         (opts (append (if (null? options)
 712                           default-dynamic-compilation-options
 713                           options)
 714                       (if (and types-file
 715                                (not predefined-types))
 716                           (list "-emit-types-file" tfile)
 717                           '())
 718                       (if inline-file
 719                           (list "-emit-inline-file" ifile)
 720                           '())))
 721         (out (target-file (conc sname ".so") mode))
 722         (src (or source (conc name ".scm")))
 723         (lobjs (map (lambda (lo)
 724                       (target-file (conc lo
 725                                          (object-extension platform))
 726                                    mode))
 727                  link-objects))
 728         (imps (map (lambda (m)
 729                      (prefix srcdir (conc m ".import.scm")))
 730                 modules))
 731         (targets (append (list out)
 732                          (maybe inline-file ifile)
 733                          (maybe (and types-file
 734                                      (not predefined-types)) tfile)
 735                          imps)))
 736    (add-dependency-target name out)
 737    (when custom
 738      (prepare-custom-command cmd platform))
 739    (print-build-command targets
 740			 `(,src ,eggfile ,@(if custom (list cmd) '())
 741			   ,@(filelist srcdir lobjs)
 742			   ,@(filelist srcdir source-dependencies)
 743                           ,@(get-dependency-targets dependencies))
 744			 `(,@(if custom '("sh") '())
 745			    ,cmd ,@(if keep-generated-files '("-k") '())
 746				,@(if (eq? mode 'host) '("-host") '())
 747				"-D" "compiling-extension"
 748				"-J" "-s" "-regenerate-import-libraries"
 749				"-setup-mode" "-I" ,srcdir
 750				"-C" ,(conc "-I" srcdir)
 751				,@opts
 752				,@link-options
 753				,src
 754				,@(filelist srcdir lobjs)
 755				"-o" ,out)
 756			 platform)
 757    (print-end-command platform)))
 758
 759(define ((compile-import-library name #!key mode
 760                                 source-dependencies
 761                                 (options '()) (link-options '()))
 762         srcdir platform)
 763  (let* ((cmd default-csc)
 764         (sname (prefix srcdir name))
 765         (opts (if (null? options)
 766                   default-import-library-compilation-options
 767                   options))
 768         (out (target-file (conc sname ".import.so") mode))
 769         (src (conc name ".import.scm")))
 770    (print-build-command (list out)
 771			 ;; TODO: eggfile not part of dependencies?
 772			 `(,src #;,eggfile ,@(filelist srcdir source-dependencies))
 773			 `(,cmd ,@(if keep-generated-files '("-k") '())
 774			   "-setup-mode" "-s"
 775			   ,@(if (eq? mode 'host) '("-host") '())
 776			   "-I" ,srcdir "-C" ,(conc "-I" srcdir)
 777			   ,@opts ,@link-options
 778			   ,src
 779			   "-o" ,out)
 780			 platform)
 781    (print-end-command platform)))
 782
 783(define ((compile-static-object name #!key mode dependencies
 784                                source-dependencies
 785                                source (options '())
 786                                eggfile custom)
 787         srcdir platform)
 788  (let* ((cmd (or (custom-cmd custom srcdir platform)
 789                  default-csc))
 790         (sname (prefix srcdir name))
 791         (ssname (and source (prefix srcdir source)))
 792         (opts (if (null? options)
 793                   default-static-compilation-options
 794                   options))
 795         (out (target-file (conc sname
 796                                 ".static"
 797                                 (object-extension platform))
 798                           mode))
 799         (src (or ssname (conc sname ".c"))))
 800    (when custom
 801      (prepare-custom-command cmd platform))
 802    (print-build-command (list out)
 803			 `(,@(filelist srcdir source-dependencies) ,src ,eggfile
 804			   ,@(if custom (list cmd) '())
 805                           ,@(get-dependency-targets dependencies))
 806			 `(,@(if custom '("sh") '())
 807			    ,cmd "-setup-mode" "-static" "-I" ,srcdir
 808				,@(if (eq? mode 'host) '("-host") '())
 809				"-c" "-C" ,(conc "-I" srcdir)
 810				,@opts ,src "-o" ,out)
 811			 platform)
 812    (print-end-command platform)))
 813
 814(define ((compile-dynamic-object name #!key mode mode dependencies
 815                                 source (options '())
 816                                 eggfile
 817                                 source-dependencies
 818                                 custom)
 819         srcdir platform)
 820  (let* ((cmd (or (custom-cmd custom srcdir platform)
 821                  default-csc))
 822         (opts (if (null? options)
 823                   default-dynamic-compilation-options
 824                   options))
 825         (sname (prefix srcdir name))
 826         (ssname (and source (prefix srcdir source)))
 827         (out (target-file (conc sname
 828                                 (object-extension platform))
 829                           mode))
 830         (src (or ssname (conc sname ".c"))))
 831    (add-dependency-target name out)
 832    (when custom
 833      (prepare-custom-command cmd platform))
 834    (print-build-command (list out)
 835			 `(,src ,eggfile ,@(if custom (list cmd) '())
 836			   ,@(filelist srcdir source-dependencies)
 837                           ,@(get-dependency-targets dependencies))
 838			 `(,@(if custom '("sh") '())
 839			   ,cmd ,@(if (eq? mode 'host) '("-host") '())
 840			   "-s" "-c" "-C" ,(conc "-I" srcdir)
 841			   ,@opts ,src "-o" ,out)
 842			 platform)
 843    (print-end-command platform)))
 844
 845(define ((compile-dynamic-program name #!key source mode dependencies
 846                                  (options '()) (link-options '())
 847                                  source-dependencies
 848                                  custom eggfile link-objects)
 849         srcdir platform)
 850  (let* ((cmd (or (custom-cmd custom srcdir platform)
 851		  default-csc))
 852         (sname (prefix srcdir name))
 853         (opts (if (null? options)
 854                   default-dynamic-compilation-options
 855                   options))
 856         (out (target-file (conc sname
 857				 (executable-extension platform))
 858			   mode))
 859         (lobjs (map (lambda (lo)
 860                       (target-file (conc lo
 861                                          (object-extension platform))
 862                                    mode))
 863                  link-objects))
 864         (src (or source (conc name ".scm"))))
 865    (when custom
 866      (prepare-custom-command cmd platform))
 867    (print-build-command (list out)
 868			 `(,src ,eggfile ,@(if custom (list cmd) '())
 869			   ,@(filelist srcdir source-dependencies)
 870			   ,@(filelist srcdir lobjs)
 871                           ,@(get-dependency-targets dependencies))
 872			 `(,@(if custom '("sh") '())
 873			    ,cmd ,@(if keep-generated-files '("-k") '())
 874				"-setup-mode"
 875				,@(if (eq? mode 'host) '("-host") '())
 876				"-I" ,srcdir
 877				"-C" ,(conc "-I" srcdir)
 878				,@opts ,@link-options ,src
 879				,@(filelist srcdir lobjs)
 880				"-o" ,out)
 881			 platform)
 882    (print-end-command platform)))
 883
 884(define ((compile-static-program name #!key source dependencies
 885                                 (options '()) (link-options '())
 886                                 source-dependencies
 887                                 custom mode eggfile link-objects)
 888         srcdir platform)
 889  (let* ((cmd (or (custom-cmd custom srcdir platform)
 890		  default-csc))
 891         (sname (prefix srcdir name))
 892         (opts (if (null? options)
 893                   default-static-compilation-options
 894                   options))
 895         (out (target-file (conc sname
 896				 (executable-extension platform))
 897			   mode))
 898         (lobjs (map (lambda (lo)
 899                       (target-file (conc lo
 900                                          (object-extension platform))
 901                                    mode))
 902                  link-objects))
 903         (src (or source (conc name ".scm"))))
 904    (when custom
 905      (prepare-custom-command cmd platform))
 906    (print-build-command (list out)
 907			 `(,src ,eggfile ,@(if custom (list cmd) '())
 908			   ,@(filelist srcdir lobjs)
 909			   ,@(filelist srcdir source-dependencies)
 910                           ,@(get-dependency-targets dependencies))
 911			 `(,@(if custom '("sh") '())
 912			    ,cmd ,@(if keep-generated-files '("-k") '())
 913				,@(if (eq? mode 'host) '("-host") '())
 914				"-static" "-setup-mode" "-I" ,srcdir
 915				"-C" ,(conc "-I" srcdir)
 916				,@opts ,@link-options ,src
 917				,@(filelist srcdir lobjs)
 918				"-o" ,out)
 919			 platform)
 920    (print-end-command platform)))
 921
 922(define ((compile-generated-file name #!key source custom dependencies
 923                                 source-dependencies eggfile)
 924         srcdir platform)
 925  (let ((cmd (custom-cmd custom srcdir platform))
 926        (out (or source name)))
 927    (add-dependency-target name out)
 928    (prepare-custom-command cmd platform)
 929    (print-build-command (list out)
 930			 (append
 931			   (filelist srcdir source-dependencies)
 932                           (get-dependency-targets dependencies))
 933			 `("sh" ,cmd ,eggfile)
 934			 platform)
 935    (print-end-command platform)))
 936
 937
 938;; installation operations
 939
 940(define ((install-static-extension name #!key mode output-file
 941                                   link-objects)
 942         srcdir platform)
 943  (let* ((cmd (install-file-command platform))
 944         (mkdir (mkdir-command platform))
 945         (ext (if (null? link-objects)
 946                  (object-extension platform)
 947                  (archive-extension platform)))
 948         (sname (prefix srcdir name))
 949         (out (qs* (target-file (conc sname ".static" ext) mode)))
 950         (outlnk (qs* (conc sname +link-file-extension+)))
 951         (dest (effective-destination-repository mode))
 952         (dfile (qs* dest))
 953         (ddir (shell-variable "DESTDIR")))
 954    (print "\n" mkdir " " ddir dfile)
 955    (print cmd " " out " " ddir
 956           (qs* (conc dest "/" output-file ext)))
 957    (print cmd " " outlnk " " ddir
 958           (qs* (conc dest "/" output-file +link-file-extension+)))
 959    (print-end-command platform)))
 960
 961(define ((install-dynamic-extension name #!key mode (ext ".so")
 962                                    output-file)
 963         srcdir platform)
 964  (let* ((cmd (install-executable-command platform))
 965         (mkdir (mkdir-command platform))
 966         (sname (prefix srcdir name))
 967         (out (qs* (target-file (conc sname ext) mode)))
 968         (dest (effective-destination-repository mode))
 969         (dfile (qs* dest))
 970         (ddir (shell-variable "DESTDIR"))
 971         (destf (qs* (conc dest "/" output-file ext))))
 972    (print "\n" mkdir " " ddir dfile)
 973    (print cmd " " out " " ddir destf)
 974    (print-end-command platform)))
 975
 976(define ((install-import-library name #!key mode)
 977         srcdir platform)
 978  ((install-dynamic-extension name mode: mode ext: ".import.so"
 979                              output-file: name)
 980   srcdir platform))
 981
 982(define ((install-import-library-source name #!key mode)
 983         srcdir platform)
 984  (let* ((cmd (install-file-command platform))
 985         (mkdir (mkdir-command platform))
 986         (sname (prefix srcdir name))
 987         (out (qs* (target-file (conc sname ".import.scm") mode)))
 988         (dest (effective-destination-repository mode))
 989         (dfile (qs* dest))
 990         (ddir (shell-variable "DESTDIR")))
 991    (print "\n" mkdir " " ddir dfile)
 992    (print cmd " " out " " ddir
 993          (qs* (conc dest "/" name ".import.scm")))
 994    (print-end-command platform)))
 995
 996(define ((install-types-file name #!key mode types-file)
 997         srcdir platform)
 998  (let* ((cmd (install-file-command platform))
 999         (mkdir (mkdir-command platform))
 1000         (out (qs* (prefix srcdir (conc types-file ".types"))))
1001         (dest (effective-destination-repository mode))
1002         (dfile (qs* dest))
1003         (ddir (shell-variable "DESTDIR")))
1004    (print "\n" mkdir " " ddir dfile)
1005    (print cmd " " out " " ddir
1006          (qs* (conc dest "/" types-file ".types")))
1007    (print-end-command platform)))
1008
1009(define ((install-inline-file name #!key mode inline-file)
1010         srcdir platform)
1011  (let* ((cmd (install-file-command platform))
1012         (mkdir (mkdir-command platform))
1013         (out (qs* (prefix srcdir (conc inline-file ".inline"))))
1014         (dest (effective-destination-repository mode))
1015         (dfile (qs* dest))
1016         (ddir (shell-variable "DESTDIR")))
1017    (print "\n" mkdir " " ddir dfile)
1018    (print cmd " " out " " ddir
1019          (qs* (conc dest "/" inline-file ".inline")))
1020    (print-end-command platform)))
1021
1022(define ((install-program name #!key mode output-file) srcdir platform)
1023  (let* ((cmd (install-executable-command platform))
1024         (mkdir (mkdir-command platform))
1025         (ext (executable-extension platform))
1026         (sname (prefix srcdir name))
1027         (out (qs* (target-file (conc sname ext) mode)))
1028         (dest (if (eq? mode 'target)
1029                   default-bindir
1030                   (override-prefix "/bin" host-bindir)))
1031         (dfile (qs* dest))
1032         (ddir (shell-variable "DESTDIR"))
1033         (destf (qs* (conc dest "/" output-file ext))))
1034    (print "\n" mkdir " " ddir dfile)
1035    (print cmd " " out " " ddir destf)
1036    (print-end-command platform)))
1037
1038(define ((install-object name #!key mode output-file) srcdir platform)
1039  (let* ((cmd (install-file-command platform))
1040         (mkdir (mkdir-command platform))
1041         (ext (object-extension platform))
1042         (sname (prefix srcdir name))
1043         (out (qs* (target-file (conc sname ext) mode)))
1044         (dest (effective-destination-repository mode))
1045         (dfile (qs* dest))
1046         (ddir (shell-variable "DESTDIR")))
1047    (print "\n" mkdir " " ddir dfile)
1048    (print cmd " " out " " ddir
1049           (qs* (conc dest "/" output-file ext)))
1050    (print-end-command platform)))
1051
1052(define (install-random-files dest files mode srcdir platform)
1053  (let* ((fcmd (install-file-command platform))
1054         (dcmd (copy-directory-command platform))
1055         (root (string-append srcdir "/"))
1056         (mkdir (mkdir-command platform))
1057         (sfiles (map (cut prefix srcdir <>) files))
1058         (dfile (qs* dest))
1059         (ddir (shell-variable "DESTDIR")))
1060    (print "\n" mkdir " " ddir dfile)
1061    (let-values (((ds fs) (partition directory? sfiles)))
1062      (for-each
1063       (lambda (d)
1064         (let* ((ds (strip-dir-prefix srcdir d))
1065                (fdir (pathname-directory ds)))
1066           (when fdir
1067             (print mkdir " " ddir
1068                    (qs* (make-pathname dest fdir))))
1069           (print dcmd " " (qs* d)
1070                  " " ddir
1071                  (if fdir
1072                      (qs* (make-pathname dest fdir))
1073                      dfile))
1074           (print-end-command platform)))
1075       ds)
1076      (when (pair? fs)
1077        (for-each
1078          (lambda (f)
1079            (let* ((fs (strip-dir-prefix srcdir f))
1080                   (fdir (pathname-directory fs)))
1081              (when fdir
1082                (print mkdir " " ddir
1083                       (qs* (make-pathname dest fdir))))
1084              (print fcmd " " (qs* f)
1085                     " " ddir
1086                     (if fdir
1087                         (qs* (make-pathname dest fdir))
1088                         dfile)))
1089            (print-end-command platform))
1090          fs)))))
1091
1092(define ((install-data name #!key files destination mode)
1093         srcdir platform)
1094  (install-random-files (or destination
1095                            (if (eq? mode 'target)
1096                                default-sharedir
1097                                (override-prefix "/share"
1098                                                 host-sharedir)))
1099                        files mode srcdir platform))
1100
1101(define ((install-c-include name #!key deps files destination mode)
1102         srcdir platform)
1103  (install-random-files (or destination
1104                            (if (eq? mode 'target)
1105                                default-incdir
1106                                (override-prefix "/include"
1107                                                 host-incdir)))
1108                        files mode srcdir platform))
1109
1110;; manage dependency-targets
1111
1112(define (add-dependency-target target output)
1113  (cond ((assq target dependency-targets) =>
1114         (lambda (a)
1115           (set-cdr! a output)))
1116        (else (set! dependency-targets
1117                (cons (cons target output) dependency-targets)))))
1118
1119(define (get-dependency-targets targets)
1120  (append-map
1121    (lambda (t)
1122      (cond ((assq t dependency-targets) => (lambda (a) (list (cdr a))))
1123            (else '())))
1124    targets))
1125
1126
1127;;; Generate shell or batch commands from abstract build/install operations
1128
1129(define (generate-shell-commands platform cmds dest srcdir prefix suffix keep)
1130  (fluid-let ((keep-generated-files keep))
1131    (with-output-to-file dest
1132      (lambda ()
1133        (prefix platform)
1134        (print (cd-command platform) " " (qs* srcdir))
1135        (for-each
1136          (lambda (cmd) (cmd srcdir platform))
1137          cmds)
1138        (suffix platform)))))
1139
1140
1141;;; affixes for build- and install-scripts
1142
1143(define ((build-prefix mode name info) platform)
1144  (printf #<<EOF
1145#!/bin/sh~%
1146set -e
1147PATH=~a:$PATH
1148export CHICKEN_CC=~a
1149export CHICKEN_CXX=~a
1150export CHICKEN_CSC=~a
1151export CHICKEN_CSI=~a
1152
1153EOF
1154             (qs* default-bindir) (qs* default-cc)
1155	     (qs* default-cxx) (qs* default-csc)
1156	     (qs* default-csi)))
1157
1158(define ((build-suffix mode name info) platform)
1159  (printf #<<EOF
1160EOF
1161             ))
1162
1163(define ((install-prefix mode name info) platform)
1164  (printf #<<EOF
1165#!/bin/sh~%
1166set -e
1167
1168EOF
1169             ))
1170
1171(define ((install-suffix mode name info) platform)
1172  (let* ((infostr (with-output-to-string (cut pp info)))
1173         (dcmd (remove-file-command platform))
1174         (mkdir (mkdir-command platform))
1175         (dir (destination-repository mode))
1176         (qdir (qs* dir))
1177         (dest (qs* (make-pathname dir name +egg-info-extension+)))
1178         (ddir (shell-variable "DESTDIR")))
1179     (printf #<<EOF
1180
1181~a ~a~a
1182~a ~a~a
1183cat >~a~a <<'ENDINFO'
1184~aENDINFO~%
1185EOF
1186               mkdir ddir qdir
1187               dcmd ddir dest
1188               ddir dest infostr)))
1189
1190;;; some utilities for mangling + quoting
1191
1192(define (qs* arg)
1193  (qs (->string arg)))
1194
1195(define (prefix dir name)
1196  (make-pathname dir (->string name)))
1197
1198(define (system+ str platform)
1199  (system (if (eq? platform 'windows)
1200              (string-append "sh -c \"" str "\"")
1201	      str)))
1202
1203(define (target-file fname mode)
1204  (if (eq? mode 'target) (string-append fname ".target") fname))
1205
1206(define (joins strs platform)
1207  (string-intersperse (map qs* strs) " "))
1208
1209(define (filelist dir lst)
1210  (map (cut prefix dir <>) lst))
1211
1212(define (shell-variable var)
1213  (string-append "\"${" var "}\""))
1214
1215(define prepare-custom-command void)
1216
1217(define (custom-cmd custom srcdir platform)
1218  (and custom (prefix srcdir custom)))
1219
1220(define (print-build-command targets sources command-and-args platform)
1221  (print "\n" (qs* default-builder) " "
1222         (joins targets platform)
1223         " : " (joins sources platform) " "
1224         " : " (joins command-and-args platform)))
1225
1226(define print-end-command void)
1227
1228(define (strip-dir-prefix prefix fname)
1229  (let* ((plen (string-length prefix))
1230         (p1 (substring fname 0 plen)))
1231    (assert (string=? prefix p1) "wrong prefix" prefix p1)
1232    (substring fname (add1 plen))))
1233
1234(define (maybe f x) (if f (list x) '()))
1235
1236(define (ensure-line-limit str lim)
1237  (when (>= (string-length str) lim)
1238    (error "line length exceeds platform limit: " str))
1239  str)