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