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

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