#!/usr/bin/env ikarus -b ikarus.boot --r6rs-script


(import (except (ikarus) assembler-output)
        (ikarus compiler)
        (except (ikarus system $bootstrap)
                eval-core
                current-primitive-locations
                compile-core-expr-to-port))


(define scheme-library-files
  ;;; Listed in the order in which they're loaded.
  ;;;
  ;;; Loading of the boot file may segfault if a library is
  ;;; loaded before its dependencies are loaded first.
  ;;;
  ;;; reason is that the base libraries are not a hierarchy of
  ;;; dependencies but rather an eco system in which every
  ;;; part depends on the other.
  ;;;
  ;;; For example, the printer may call error if it finds
  ;;;  an error (e.g. "not an output port"), while the error
  ;;;  procedure may call the printer to display the message.
  ;;;  This works fine as long as error does not itself cause
  ;;;  an error (which may lead to the infamous Error: Error: 
  ;;;  Error: Error: Error: Error: Error: Error: Error: ...).
  ;;;
  '("ikarus.singular-objects.ss"
    "ikarus.handlers.ss"
    "ikarus.multiple-values.ss"
    "ikarus.control.ss"
    "ikarus.collect.ss"
    "ikarus.apply.ss"
    "ikarus.predicates.ss"
    "ikarus.pairs.ss"
    "ikarus.lists.ss"
    "ikarus.fixnums.ss"
    "ikarus.chars.ss"
    "ikarus.records.ss"
    "ikarus.strings.ss"
    "ikarus.date-string.ss"
    "ikarus.symbols.ss"
    "ikarus.vectors.ss"
    "ikarus.numerics.ss"
    "ikarus.guardians.ss"
    "ikarus.command-line.ss"
    "ikarus.io-ports.ss"
    "ikarus.io-primitives.unsafe.ss"
    "ikarus.io-primitives.ss"
    "ikarus.io.input-files.ss"
    "ikarus.io.output-files.ss"
    "ikarus.io.input-strings.ss"
    "ikarus.io.output-strings.ss"
    "ikarus.hash-tables.ss"
    "ikarus.writer.ss"
    "ikarus.reader.ss"
    "ikarus.code-objects.ss"
    "ikarus.intel-assembler.ss"
    "ikarus.trace.ss"
    "ikarus.fasl.write.ss"
    "ikarus.fasl.ss"
    "ikarus.compiler.ss"
    "ikarus.library-manager.ss"
    "ikarus.syntax.ss"
    "ikarus.load.ss"
    "ikarus.pretty-print.ss"
    "ikarus.cafe.ss"
    "ikarus.posix.ss"
    "ikarus.timer.ss"
    "ikarus.main.ss"))

(define ikarus-system-macros
  '([define            (define)]
    [define-syntax     (define-syntax)]
    [module            (module)]
    [begin             (begin)]
    [set!              (set!)]
    [foreign-call      (core-macro . foreign-call)]
    [quote             (core-macro . quote)]
    [syntax-case       (core-macro . syntax-case)]
    [syntax            (core-macro . syntax)]
    [lambda            (core-macro . lambda)]
    [case-lambda       (core-macro . case-lambda)]
    [type-descriptor   (core-macro . type-descriptor)]
    [letrec            (core-macro . letrec)]
    [letrec*           (core-macro . letrec*)]
    [if                (core-macro . if)]
    [when              (core-macro . when)]         
    [unless            (core-macro . unless)]
    [parameterize      (core-macro . parameterize)]
    [case              (core-macro . case)]
    [let-values        (core-macro . let-values)]
    [define-record     (macro . define-record)]
    [include           (macro . include)]
    [syntax-rules      (macro . syntax-rules)]
    [quasiquote        (macro . quasiquote)]
    [with-syntax       (macro . with-syntax)]
    [let               (macro . let)]
    [let*              (macro . let*)]
    [cond              (macro . cond)]
    [do                (macro . do)]
    [and               (macro . and)]
    [or                (macro . or)]))

(define library-legend
  '([i           (ikarus)                     #t]
    [symbols     (ikarus symbols)             #t]
    [parameters  (ikarus parameters)          #t]
    [interaction (ikarus interaction)         #t]
    [r           (r6rs)                       #t]
    [syncase     (r6rs syntax-case)           #t]
    [cm          (chez modules)               #t]
    [$all        (ikarus system $all)         #f]
    [$pairs      (ikarus system $pairs)       #f]
    [$lists      (ikarus system $lists)       #f]
    [$chars      (ikarus system $chars)       #f]
    [$strings    (ikarus system $strings)     #f]
    [$vectors    (ikarus system $vectors)     #f]
    [$bytes      (ikarus system $bytevectors) #f]
    [$fx         (ikarus system $fx)          #f]
    [$symbols    (ikarus system $symbols)     #f]
    [$records    (ikarus system $records)     #f]
    [$ports      (ikarus system $ports)       #f]
    [$codes      (ikarus system $codes)       #f]
    [$tcbuckets  (ikarus system $tcbuckets)   #f]
    [$io         (ikarus system $io)          #f]
    [$arg-list   (ikarus system $arg-list)    #f]
    [$stack      (ikarus system $stack)       #f]
    [$interrupts (ikarus system $interrupts)  #f]
    [$boot       (ikarus system $bootstrap)   #f]
    ))


(define bootstrap-collection
  (let ([ls (map 
              (lambda (x) 
                (find-library-by-name (cadr x)))
              library-legend)])
    (case-lambda
      [() ls]
      [(x) (unless (memq x ls) 
             (set! ls (cons x ls)))])))



(define ikarus-macros-map
  '([define           i r]
    [define-syntax    i r]
    [module           i cm]
    [begin            i r]
    [set!             i r]
    [foreign-call     i]
    [quote            i r]
    [syntax-case      i syncase]
    [syntax           i syncase]
    [lambda           i r]
    [case-lambda      i r]
    [type-descriptor  i  ]
    [letrec           i r]
    [letrec*          i r]
    [if               i r]
    [when             i r]
    [unless           i r]
    [parameterize     i parameters]
    [case             i r]
    [let-values       i r]
    [define-record    i r]
    [include          i r]
    [syntax-rules     i r]
    [quasiquote       i r]
    [with-syntax      i syncase]
    [let              i r]
    [let*             i r]
    [cond             i r]
    [do               i r]
    [and              i r]
    [or               i r]))

(define ikarus-procedures-map
  '([void                    i]
    [not                     i r]
    [boolean?                i r]
    [null?                   i r]
    [procedure?              i r]
    [eof-object?             i r]
    [eof-object              i]
    [eq?                     i r]
    [eqv?                    i r]
    [equal?                  i r]
    [cons                    i r]
    [pair?                   i r]
    [car                     i r]
    [cdr                     i r]
    [set-car!                i]
    [set-cdr!                i]
    [caar                    i r]
    [cdar                    i r]
    [cadr                    i r]
    [cddr                    i r]
    [caaar                   i r]
    [cdaar                   i r]
    [cadar                   i r]
    [cddar                   i r]
    [caadr                   i r]
    [cdadr                   i r]
    [caddr                   i r]
    [cdddr                   i r]
    [caaaar                  i r]
    [cdaaar                  i r]
    [cadaar                  i r]
    [cddaar                  i r]
    [caadar                  i r]
    [cdadar                  i r]
    [caddar                  i r]
    [cdddar                  i r]
    [caaadr                  i r]
    [cdaadr                  i r]
    [cadadr                  i r]
    [cddadr                  i r]
    [caaddr                  i r]
    [cdaddr                  i r]
    [cadddr                  i r]
    [cddddr                  i r]
    [list                    i r]
    [list-ref                i r]
    [make-list               i r]
    [list*                   i]
    [list?                   i r]
    [append                  i r]
    [last-pair               i r]
    [reverse                 i r]
    [length                  i r]
    [assq                    i r]
    [assv                    i r]
    [assoc                   i r]
    [memq                    i r]
    [memv                    i r]
    [member                  i r]
    [bwp-object?             i]
    [weak-cons               i]
    [weak-pair?              i]
    [char?                   i r]
    [char=?                  i r]
    [char<?                  i r]
    [char>?                  i r]
    [char<=?                 i r]
    [char>=?                 i r]
    [integer->char           i r]
    [char->integer           i r]
    [char-whitespace?        i r]
    [string?                 i r]
    [string                  i r]
    [make-string             i r]
    [string-ref              i r]
    [string-set!             i r]
    [string-length           i r]
    [string=?                i r]
    [substring               i r]
    [string-append           i r]
    [string->list            i r]
    [list->string            i r]
    [uuid                    i]
    [date-string             i]
    [vector                  i r]
    [make-vector             i r]
    [vector-ref              i r]
    [vector-set!             i r]
    [vector?                 i r]
    [vector-length           i r]
    [list->vector            i r]
    [vector->list            i r]
    [for-each                i r]
    [map                     i r]
    [andmap                  i]
    [ormap                   i]
    [fixnum?                 i]
    [fx<                     i]
    [fx<=                    i]
    [fx>                     i]
    [fx>=                    i]
    [fx=                     i]
    [fx-                     i]
    [fx+                     i]
    [fx*                     i]
    [fxzero?                 i]
    [fxadd1                  i]
    [fxsub1                  i]
    [fxquotient              i]
    [fxremainder             i]
    [fxmodulo                i]
    [fxsll                   i]
    [fxsra                   i]
    [fxlogand                i]
    [fxlogxor                i]
    [fxlogor                 i]
    [fxlognot                i]
    [fixnum->string          i]
    [string->flonum          i]
    [-                       i r]
    [=                       i r]
    [<                       i r]
    [>                       i r]
    [<=                      i r]
    [>=                      i r]
    [zero?                   i r]
    [*                       i r]
    [+                       i r]
    [add1                    i]
    [sub1                    i]
    [number?                 i r]
    [bignum?                 i]
    [integer?                i]
    [flonum?                 i]
    [positive?               i r]
    [quotient                i r]
    [remainder               i r]
    [quotient+remainder      i r]
    [number->string          i r]
    [string->number          i r]
    [flonum->string          i]
    [symbol?                 i r symbols]
    [gensym?                 i symbols]
    [gensym                  i symbols]
    [getprop                 i symbols]
    [putprop                 i symbols]
    [remprop                 i symbols]
    [property-list           i symbols]
    [string->symbol          i r symbols]
    [symbol->string          i r symbols]
    [gensym->unique-string   i symbols]
    [symbol-bound?           i symbols]
    [symbol-value            i symbols]
    [set-symbol-value!       i symbols]
    [make-guardian           i]
    [make-input-port         i]
    [make-output-port        i]
    [make-input/output-port  i]
    [port-output-index       i]
    [port-output-size        i]
    [port-output-buffer      i]
    [set-port-output-index!  i]
    [set-port-output-size!   i]
    [port-input-buffer       i]
    [port-input-index        i]
    [port-input-size         i]
    [set-port-input-index!   i]
    [set-port-input-size!    i]
    [output-port?            i r]
    [input-port?             i r]
    [port?                   i r]
    [port-name               i]
    [input-port-name         i]
    [output-port-name        i]
    [open-input-file         i r]
    [with-input-from-file    i r]
    [with-output-to-file     i r]
    [open-output-file        i r]
    [open-output-string      i]
    [open-input-string       i]
    [get-output-string       i]
    [with-output-to-string   i]
    [close-input-port        i r]
    [close-output-port       i r]
    [console-input-port      i]
    [console-output-port     i]
    [current-input-port      i]
    [current-output-port     i]
    [standard-input-port     i]
    [standard-output-port    i]
    [standard-error-port     i]
    [flush-output-port       i]
    [reset-input-port!       i]
    [file-exists?            i]
    [display                 i r]
    [write                   i r]
    [write-char              i]
    [read                    i r]
    [read-char               i r]
    [read-token              i]
    [peek-char               i]
    [unread-char             i]
    [newline                 i r]
    [printf                  i]
    [format                  i]
    [pretty-print            i]
    [comment-handler         i]
    [print-gensym            i symbols]
    [gensym-count            i symbols]
    [gensym-prefix           i symbols]
    [make-hash-table         i]
    [hash-table?             i]
    [get-hash-table          i]
    [put-hash-table!         i]
    [make-parameter          i parameters]
    [apply                   i r]
    [values                  i r]
    [call-with-values        i r]
    [call/cc                 i r]
    [call-with-current-continuation i r]
    [call/cf                 i]
    [dynamic-wind            i r]
    [error                   i]
    [print-error             i]
    [error-handler           i]
    [interrupt-handler       i]
    [exit                    i]
    [load                    i]
    [assembler-output        i]
    [new-cafe                i]
    [eval                    i]
    [environment             i]
    [environment?            i]
    [time-it                 i]
    [command-line-arguments  i]
    [record?                 i]
    [make-record-type        i]
    [record-type-descriptor  i]
    [record-type-field-names i]
    [record-type-symbol      i]
    [record-type-name        i]
    [set-rtd-printer!        i]
    [record-name             i]
    [record-constructor      i]
    [record-predicate        i]
    [record-length           i]
    [record-printer          i]
    [record-ref              i]
    [record-set!             i]
    [record-field-accessor   i]
    [record-field-mutator    i]
    [identifier?             i syncase]
    [syntax-error            i syncase]
    [generate-temporaries    i syncase]
    [free-identifier=?       i syncase]
    [bound-identifier=?      i syncase]
    [syntax->datum           i syncase]
    [datum->syntax           i syncase]
    [code?                   i]
    [immediate?              i]
    [pointer-value           i]

    [installed-libraries     i]
    [compile-core-expr-to-port   $boot]
    [current-primitive-locations $boot]
    [boot-library-expand         $boot]
    [eval-core                   $boot]
    [current-library-collection  $boot]
    [library-name                $boot]
    [find-library-by-name        $boot]

    [$car               $pairs]
    [$cdr               $pairs]
    [$set-car!          $pairs]
    [$set-cdr!          $pairs]
    
    [$memq              $lists]
    [$memv              $lists]
   
    [$char?             $chars]
    [$char=             $chars]
    [$char<             $chars]
    [$char>             $chars]
    [$char<=            $chars]
    [$char>=            $chars]
    [$char->fixnum      $chars]
    [$fixnum->char      $chars]
   
    [$make-string       $strings]
    [$string-ref        $strings]
    [$string-set!       $strings]
    [$string-length     $strings]
  
    [bytevector?        i]

    [$make-bytevector   $bytes]
    [$bytevector-length $bytes]
    [$bytevector-ref    $bytes]
    [$bytevector-set!   $bytes]


    [$make-vector       $vectors]
    [$vector-length     $vectors]
    [$vector-ref        $vectors]
    [$vector-set!       $vectors]
 
    [$fxzero?           $fx]
    [$fxadd1            $fx]
    [$fxsub1            $fx]
    [$fx>=              $fx]
    [$fx<=              $fx]
    [$fx>               $fx]
    [$fx<               $fx]
    [$fx=               $fx]
    [$fxsll             $fx]
    [$fxsra             $fx]
    [$fxquotient        $fx]
    [$fxmodulo          $fx]
    [$fxlogxor          $fx]
    [$fxlogor           $fx]
    [$fxlognot          $fx]
    [$fxlogand          $fx]
    [$fx+               $fx]
    [$fx*               $fx]
    [$fx-               $fx]

    [$make-symbol               $symbols]
    [$symbol-unique-string      $symbols]
    [$symbol-value              $symbols]
    [$symbol-string             $symbols]
    [$symbol-plist              $symbols]
    [$set-symbol-value!         $symbols]
    [$set-symbol-string!        $symbols]
    [$set-symbol-unique-string! $symbols]
    [$set-symbol-plist!         $symbols]
    [$unbound-object?           $symbols]

    [base-rtd           $records]
    [$record-set!       $records]
    [$record-ref        $records]
    [$record-rtd        $records]
    [$record            $records]
    [$make-record       $records]
    [$record?           $records]
    [$record/rtd?       $records]

    [$make-port/input         $ports]
    [$make-port/output        $ports]
    [$make-port/both          $ports]
    [$port-handler            $ports]
    [$port-input-buffer       $ports]
    [$port-input-index        $ports]
    [$port-input-size         $ports]
    [$port-output-buffer      $ports]
    [$port-output-index       $ports]
    [$port-output-size        $ports]
    [$set-port-input-index!   $ports]
    [$set-port-input-size!    $ports]
    [$set-port-output-index!  $ports]
    [$set-port-output-size!   $ports]

    [$closure-code            $codes]
    [$code->closure           $codes]
    [$code-reloc-vector       $codes]
    [$code-freevars           $codes]
    [$code-size               $codes]
    [$code-ref                $codes]
    [$code-set!               $codes]

    [$make-tcbucket           $tcbuckets]
    [$tcbucket-key            $tcbuckets]
    [$tcbucket-val            $tcbuckets]
    [$tcbucket-next           $tcbuckets]
    [$set-tcbucket-val!       $tcbuckets]
    [$set-tcbucket-next!      $tcbuckets]
    [$set-tcbucket-tconc!     $tcbuckets]

    [$flush-output-port     $io]
    [$reset-input-port!     $io]
    [$close-input-port      $io]
    [$close-output-port     $io]
    [$write-char            $io]
    [$read-char             $io]
    [$peek-char             $io]
    [$unread-char           $io]

    [$arg-list              $arg-list]

    [$$apply                          $stack]
    [$fp-at-base                      $stack]
    [$primitive-call/cc               $stack]
    [$frame->continuation             $stack]
    [$current-frame                   $stack]
    [$seal-frame-and-call             $stack]
    [$make-call-with-values-procedure $stack]
    [$make-values-procedure           $stack]

    [$interrupted?                     $interrupts]
    [$unset-interrupted!               $interrupts]
    ;;; the following must be defined but they don't have 
    ;;; to reside in any library since they're here so that
    ;;; the compiler can target them.  They're not usable 
    ;;; by the end user.
    [$apply-nonprocedure-error-handler ]
    [$incorrect-args-error-handler     ]
    [$multiple-values-error            ]
    [$debug                            ]
    [$underflow-misaligned-error       ]
    [top-level-value-error             ]
    [car-error                         ]
    [cdr-error                         ]
    [fxadd1-error                      ]
    [fxsub1-error                      ]
    [cadr-error                        ]
    [fx+-type-error                    ]
    [fx+-types-error                   ]
    [fx+-overflow-error                ]
    [$do-event                         ]
    [do-overflow                       ]
    [do-overflow-words                 ]
    [do-vararg-overflow                ]
    [collect                           ]
    [do-stack-overflow                 ]
    [syntax-dispatch                   ]
    ))

(define (verify-map)
  (define (f x)
    (for-each 
      (lambda (x) 
        (unless (assq x library-legend)
          (error 'verify "~s is not in the libraries list" x)))
      (cdr x)))
  (for-each f ikarus-procedures-map)
  (for-each f ikarus-macros-map))

(define (make-collection)
  (let ([set '()])
    (case-lambda
      [() set]
      [(x) (set! set (cons x set))])))

(define (make-system-data subst env)
  (define who 'make-system-data)
  (let ([export-subst    (make-collection)] 
        [export-env      (make-collection)]
        [export-primlocs (make-collection)])
    (for-each
      (lambda (x)
        (let ([name (car x)] [binding (cadr x)])
          (let ([label (gensym)])
            (export-subst (cons name label))
            (export-env   (cons label binding)))))
      ikarus-system-macros)
    (for-each
      (lambda (x)
        (cond
          [(assq x (export-subst))
           (error who "ambiguous export of ~s" x)]
          [(assq x subst) =>
           ;;; primitive defined (exported) within the compiled libraries
           (lambda (p)
             (let ([label (cdr p)])
               (cond
                 [(assq label env) =>
                  (lambda (p)
                    (let ([binding (cdr p)])
                      (case (car binding)
                        [(global) 
                         (export-subst (cons x label))
                         (export-env   (cons label (cons 'core-prim x)))
                         (export-primlocs (cons x (cdr binding)))]
                        [else 
                         (error #f "invalid binding ~s for ~s" p x)])))]
                 [else (error #f "cannot find binding for ~s" x)])))]
          [else 
           ;;; core primitive with no backing definition, assumed to
           ;;; be defined in other strata of the system
           (let ([label (gensym)])
             (export-subst (cons x label))
             (export-env (cons label (cons 'core-prim x))))]))
      (map car ikarus-procedures-map))
    (values (export-subst) (export-env) (export-primlocs))))

(define (get-export-subset key subst)
  (let f ([ls subst])
    (cond
      [(null? ls) '()]
      [else
       (let ([x (car ls)])
         (let ([name (car x)])
           (cond
             [(or (assq name ikarus-procedures-map)
                  (assq name ikarus-macros-map))
              =>
              (lambda (q)
                (cond
                  [(memq key (cdr q)) 
                   (cons x (f (cdr ls)))]
                  [else (f (cdr ls))]))]
             [else 
              ;;; not going to any library?
              (f (cdr ls))])))])))

(define (build-system-library export-subst export-env primlocs)
  (define (build-library legend-entry)
    (let ([key (car legend-entry)]
          [name (cadr legend-entry)]
          [visible? (caddr legend-entry)]) 
      (let ([id     (gensym)]
            [name       name]
            [version     '()]
            [import-libs '()]
            [visit-libs  '()]
            [invoke-libs '()])
        (let-values ([(subst env)
                      (if (equal? name '(ikarus system $all)) 
                          (values export-subst export-env)
                          (values
                            (get-export-subset key export-subst)
                            '()))])
          `(install-library 
             ',id ',name ',version ',import-libs ',visit-libs ',invoke-libs
             ',subst ',env void void ',visible?)))))
  (let ([code `(library (ikarus primlocs)
                  (export) ;;; must be empty
                  (import 
                    (only (ikarus library-manager)
                          install-library)
                    (only (ikarus compiler)
                          current-primitive-locations)
                    (ikarus))
                  (current-primitive-locations 
                    (lambda (x) 
                      (cond
                        [(assq x ',primlocs) => cdr]
                        [else #f])))
                  ,@(map build-library library-legend))])
    (let-values ([(code empty-subst empty-env)
                  (boot-library-expand code)])
       code)))






(define (expand-all files)
  (let ([code* '()]
        [subst '()]
        [env   '()])
    (for-each
      (lambda (file)
        (printf "expanding ~s\n" file)
        (load file
          (lambda (x) 
            (let-values ([(code export-subst export-env)
                          (boot-library-expand x)])
               (set! code* (cons code code*))
               (set! subst (append export-subst subst))
               (set! env (append export-env env))))))
      files)
    (let-values ([(export-subst export-env export-locs)
                  (make-system-data subst env)])
      (let ([code (build-system-library export-subst export-env export-locs)])
        (values 
          (reverse (list* (car code*) code (cdr code*)))
          export-locs)))))

(verify-map)

(time-it "the entire bootstrap process"
  (lambda ()
    (let-values ([(core* locs) 
                  (time-it "macro expansion"
                    (lambda () 
                      (parameterize ([current-library-collection
                                       bootstrap-collection])
                        (expand-all scheme-library-files))))])
        (current-primitive-locations
          (lambda (x)
            (cond
              [(assq x locs) => cdr]
              [else 
               (error 'bootstrap "no location for ~s" x)])))
        (let ([p (open-output-file "ikarus.boot" 'replace)])
          (for-each 
            (lambda (x) (compile-core-expr-to-port x p))
            core*)
          (close-output-port p)))))

(printf "Happy Happy Joy Joy\n")


;;; vim:syntax=scheme