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