import from compiler4
This commit is contained in:
parent
03e9649064
commit
3815bebb4c
|
@ -2,7 +2,7 @@
|
|||
all: ikarus.fasl
|
||||
|
||||
ikarus.fasl:
|
||||
echo '(load "compiler-6.2.ss")' | petite
|
||||
echo '(load "compiler-6.9.ss")' | petite
|
||||
|
||||
clean:
|
||||
rm -f *.fasl
|
||||
|
|
|
@ -1 +1 @@
|
|||
2006-08-02
|
||||
2006-08-22
|
||||
|
|
|
@ -31,5 +31,27 @@
|
|||
|
||||
(define char= char=?)
|
||||
|
||||
(set! $base-rtd #%$base-rtd)
|
||||
(define-syntax |#primitive|
|
||||
(syntax-rules ()
|
||||
[(_ n prim) prim]
|
||||
[(_ prim) prim]))
|
||||
|
||||
(define (date-string)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(define ($record rtd . args)
|
||||
(apply (record-constructor rtd) args))
|
||||
(define ($record/rtd? x rtd)
|
||||
(and (record? x) (eq? (record-type-descriptor x) rtd)))
|
||||
(define ($record-ref x i)
|
||||
((record-field-accessor (record-type-descriptor x) i) x))
|
||||
(define ($record-set! x i v)
|
||||
((record-field-mutator (record-type-descriptor x) i) x v))
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,98 @@
|
|||
|
||||
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(set! $base-rtd (eval '#%$base-rtd))
|
||||
; (set! $base-rtd #%$base-rtd)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.0.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.0.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.0.ss") ; uses code? etc.
|
||||
(load "libcompile-6.4.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.2.ss" "libcore.fasl"]
|
||||
["libio-6.1.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-compat-6.0.ss" "libassembler-compat.ss"]
|
||||
["libintelasm-6.4.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.0.ss" "libfasl.fasl"]
|
||||
["libcompile-6.4.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.1.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(system "rm -f ikarus.fasl")
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (get-date)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(with-output-to-file "petite-ikarus.ss"
|
||||
(lambda ()
|
||||
(write
|
||||
`(begin
|
||||
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
||||
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
||||
(new-cafe))))
|
||||
'replace)
|
||||
|
||||
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")
|
|
@ -0,0 +1,96 @@
|
|||
|
||||
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.5.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.0.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.0.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.0.ss") ; uses code? etc.
|
||||
(load "libcompile-6.5.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.2.ss" "libcore.fasl"]
|
||||
["libio-6.1.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-compat-6.0.ss" "libassembler-compat.ss"]
|
||||
["libintelasm-6.4.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.0.ss" "libfasl.fasl"]
|
||||
["libcompile-6.5.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(system "rm -f ikarus.fasl")
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (get-date)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(with-output-to-file "petite-ikarus.ss"
|
||||
(lambda ()
|
||||
(write
|
||||
`(begin
|
||||
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
||||
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
||||
(new-cafe))))
|
||||
'replace)
|
||||
|
||||
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")
|
|
@ -0,0 +1,97 @@
|
|||
|
||||
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.5.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.6.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.6.ss") ; uses code? etc.
|
||||
(load "libcompile-6.6.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.2.ss" "libcore.fasl"]
|
||||
["libio-6.1.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-compat-6.6.ss" "libassembler-compat.ss"]
|
||||
["libintelasm-6.6.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.6.ss" "libfasl.fasl"]
|
||||
["libcompile-6.6.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(system "rm -f ikarus.fasl")
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (get-date)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(with-output-to-file "petite-ikarus.ss"
|
||||
(lambda ()
|
||||
(write
|
||||
`(begin
|
||||
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
||||
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
||||
(new-cafe))))
|
||||
'replace)
|
||||
|
||||
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")
|
|
@ -0,0 +1,98 @@
|
|||
|
||||
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.5.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-6.7.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.2.ss" "libcore.fasl"]
|
||||
["libio-6.1.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" "libassembler.ss"]
|
||||
["libintelasm-6.6.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" "libfasl.fasl"]
|
||||
["libcompile-6.7.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(system "rm -f ikarus.fasl")
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (get-date)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(with-output-to-file "petite-ikarus.ss"
|
||||
(lambda ()
|
||||
(write
|
||||
`(begin
|
||||
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
||||
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
||||
(new-cafe))))
|
||||
'replace)
|
||||
|
||||
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")
|
|
@ -0,0 +1,98 @@
|
|||
|
||||
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.5.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-6.7.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.2.ss" "libcore.fasl"]
|
||||
["libio-6.1.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" "libassembler.ss"]
|
||||
["libintelasm-6.6.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" "libfasl.fasl"]
|
||||
["libcompile-6.7.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.8.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(system "rm -f ikarus.fasl")
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (get-date)
|
||||
(system "date +\"%F\" > build-date.tmp")
|
||||
(let ([ip (open-input-file "build-date.tmp")])
|
||||
(list->string
|
||||
(let f ()
|
||||
(let ([x (read-char ip)])
|
||||
(if (char=? x #\newline)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(with-output-to-file "petite-ikarus.ss"
|
||||
(lambda ()
|
||||
(write
|
||||
`(begin
|
||||
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
||||
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
||||
(new-cafe))))
|
||||
'replace)
|
||||
|
||||
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")
|
|
@ -0,0 +1,256 @@
|
|||
|
||||
|
||||
;;;
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call $apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure?
|
||||
not
|
||||
eof-object eof-object? bwp-object?
|
||||
void
|
||||
fx= fx< fx<= fx> fx>= fxzero?
|
||||
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
|
||||
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
|
||||
integer->char char->integer
|
||||
char=? char<? char<=? char>? char>=?
|
||||
cons car cdr set-car! set-cdr!
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
list list* make-list length list-ref
|
||||
append
|
||||
make-vector vector-ref vector-set! vector-length vector
|
||||
vector->list list->vector
|
||||
make-string string-ref string-set! string-length string list->string
|
||||
uuid
|
||||
string-append substring
|
||||
string=? string<? string<=? string>? string>=?
|
||||
remprop putprop getprop property-list
|
||||
apply
|
||||
map for-each andmap ormap
|
||||
memq memv assq
|
||||
eq? equal?
|
||||
reverse
|
||||
string->symbol symbol->string oblist
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string
|
||||
call-with-values values
|
||||
make-parameter dynamic-wind
|
||||
output-port? current-output-port standard-output-port console-output-port
|
||||
open-output-file close-output-port flush-output-port output-port-name
|
||||
with-output-to-file with-input-from-file
|
||||
input-port? current-input-port standard-input-port console-input-port
|
||||
reset-input-port!
|
||||
open-input-file close-input-port input-port-name
|
||||
standard-error-port
|
||||
open-output-string get-output-string
|
||||
newline write-char peek-char read-char unread-char
|
||||
display write fasl-write printf format print-error
|
||||
read-token read
|
||||
error exit call/cc
|
||||
current-error-handler
|
||||
eval current-eval interpret compile compile-file new-cafe load
|
||||
system
|
||||
expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment
|
||||
identifier? free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list
|
||||
generate-temporaries
|
||||
record? record-set! record-ref record-length
|
||||
record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output
|
||||
$make-environment
|
||||
features
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value
|
||||
primitive-ref primitive-set!
|
||||
$fx= $fx< $fx<= $fx> $fx>= $fxzero?
|
||||
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo
|
||||
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
|
||||
$fixnum->char $char->fixnum
|
||||
$char= $char< $char<= $char> $char>=
|
||||
$car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
|
||||
$make-symbol $set-symbol-plist! $symbol-plist
|
||||
$sc-put-cte
|
||||
$record? $record/rtd? $record-set! $record-ref $record-rtd
|
||||
$make-record $record
|
||||
$base-rtd
|
||||
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
|
||||
$code->closure list*->code*
|
||||
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
code-size code-ref code-set!
|
||||
$frame->continuation $fp-at-base $current-frame $seal-frame-and-call
|
||||
$make-call-with-values-procedure $make-values-procedure
|
||||
do-overflow collect
|
||||
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
|
||||
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
|
||||
call/cf trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string date-string
|
||||
vector-memq vector-memv
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(#%date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-6.7.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.9.ss" "libcore.fasl"]
|
||||
["libio-6.9.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" "libassembler.ss"]
|
||||
["libintelasm-6.9.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" "libfasl.fasl"]
|
||||
["libcompile-6.7.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.9.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
["libtrace-6.9.ss" "libtrace.fasl"]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.9.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.fasl"
|
||||
(join " " (map cadr scheme-library-files))))
|
|
@ -0,0 +1,261 @@
|
|||
|
||||
|
||||
;;;
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call $apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure?
|
||||
not
|
||||
eof-object eof-object? bwp-object?
|
||||
void
|
||||
fx= fx< fx<= fx> fx>= fxzero?
|
||||
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
|
||||
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
|
||||
integer->char char->integer
|
||||
char=? char<? char<=? char>? char>=?
|
||||
cons car cdr set-car! set-cdr!
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
list list* make-list length list-ref
|
||||
append
|
||||
make-vector vector-ref vector-set! vector-length vector
|
||||
vector->list list->vector
|
||||
make-string string-ref string-set! string-length string list->string
|
||||
uuid
|
||||
string-append substring
|
||||
string=? string<? string<=? string>? string>=?
|
||||
remprop putprop getprop property-list
|
||||
apply
|
||||
map for-each andmap ormap
|
||||
memq memv assq
|
||||
eq? equal?
|
||||
reverse
|
||||
string->symbol symbol->string oblist
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string
|
||||
call-with-values values
|
||||
make-parameter dynamic-wind
|
||||
output-port? current-output-port standard-output-port console-output-port
|
||||
open-output-file close-output-port flush-output-port output-port-name
|
||||
with-output-to-file with-input-from-file
|
||||
input-port? current-input-port standard-input-port console-input-port
|
||||
reset-input-port!
|
||||
open-input-file close-input-port input-port-name
|
||||
standard-error-port
|
||||
open-output-string get-output-string
|
||||
newline write-char peek-char read-char unread-char
|
||||
display write fasl-write printf format print-error
|
||||
read-token read
|
||||
error exit call/cc
|
||||
current-error-handler
|
||||
eval current-eval interpret compile compile-file new-cafe load
|
||||
system
|
||||
expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment
|
||||
identifier? free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list
|
||||
generate-temporaries
|
||||
record? record-set! record-ref record-length
|
||||
record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output
|
||||
$make-environment
|
||||
features
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value
|
||||
primitive-ref primitive-set!
|
||||
$fx= $fx< $fx<= $fx> $fx>= $fxzero?
|
||||
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo
|
||||
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
|
||||
$fixnum->char $char->fixnum
|
||||
$char= $char< $char<= $char> $char>=
|
||||
$car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
|
||||
$make-symbol $set-symbol-plist! $symbol-plist
|
||||
$sc-put-cte
|
||||
$record? $record/rtd? $record-set! $record-ref $record-rtd
|
||||
$make-record $record
|
||||
$base-rtd
|
||||
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
|
||||
$code->closure list*->code*
|
||||
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
code-size code-ref code-set!
|
||||
$frame->continuation $fp-at-base $current-frame $seal-frame-and-call
|
||||
$make-call-with-values-procedure $make-values-procedure
|
||||
do-overflow collect
|
||||
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
|
||||
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
|
||||
call/cf trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string date-string
|
||||
vector-memq vector-memv
|
||||
|
||||
|
||||
|
||||
port? input-port? output-port? $make-input-port make-input-port $make-output-port make-output-port $make-input/output-port make-input/output-port $port-handler port-handler $port-input-buffer port-input-buffer $port-input-index port-input-index $port-input-size port-input-size $port-output-buffer port-output-buffer $port-output-index port-output-index $port-output-size port-output-size $set-port-input-index! set-port-input-index! $set-port-input-size! set-port-input-size! $set-port-output-index! set-port-output-index! $set-port-output-size! set-port-output-size! $write-char write-char newline port-name input-port-name output-port-name $read-char read-char $unread-char unread-char $peek-char peek-char $unread-char $reset-input-port! reset-input-port! $close-input-port close-input-port $close-output-port close-output-port $flush-output-port flush-output-port *standard-input-port* console-input-port *current-input-port* current-input-port *standard-output-port* *current-output-port* *standard-error-port* standard-output-port standard-error-port console-output-port current-output-port *current-output-port* open-output-file open-output-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file
|
||||
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(#%date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-6.7.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.4.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.9.ss" "libcore.fasl"]
|
||||
["libio-6.9.ss" "libio.fasl"]
|
||||
["libwriter-6.2.ss" "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" "libassembler.ss"]
|
||||
["libintelasm-6.9.ss" "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" "libfasl.fasl"]
|
||||
["libcompile-6.7.ss" "libcompile.fasl"]
|
||||
["psyntax-7.1-6.9.ss" "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" "libcafe.fasl"]
|
||||
["libtrace-6.9.ss" "libtrace.fasl"]
|
||||
["libposix-6.0.ss" "libposix.fasl"]
|
||||
["libhash-6.2.ss" "libhash.fasl"]
|
||||
["libtoplevel-6.9.ss" "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x)))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.fasl"
|
||||
(join " " (map cadr scheme-library-files))))
|
|
@ -0,0 +1,289 @@
|
|||
|
||||
|
||||
;;; 8.1: * using chez-style io ports
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call $apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure?
|
||||
not
|
||||
eof-object eof-object? bwp-object?
|
||||
void
|
||||
fx= fx< fx<= fx> fx>= fxzero?
|
||||
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
|
||||
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
|
||||
integer->char char->integer
|
||||
char=? char<? char<=? char>? char>=?
|
||||
cons car cdr set-car! set-cdr!
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
list list* make-list length list-ref
|
||||
append
|
||||
make-vector vector-ref vector-set! vector-length vector
|
||||
vector->list list->vector
|
||||
make-string string-ref string-set! string-length string list->string
|
||||
uuid
|
||||
string-append substring
|
||||
string=? string<? string<=? string>? string>=?
|
||||
remprop putprop getprop property-list
|
||||
apply
|
||||
map for-each andmap ormap
|
||||
memq memv assq
|
||||
eq? equal?
|
||||
reverse
|
||||
string->symbol symbol->string oblist
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string
|
||||
call-with-values values
|
||||
make-parameter dynamic-wind
|
||||
display write fasl-write printf format print-error
|
||||
read-token read
|
||||
error exit call/cc
|
||||
current-error-handler
|
||||
eval current-eval interpret compile compile-file new-cafe load
|
||||
system
|
||||
expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment
|
||||
identifier? free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list
|
||||
generate-temporaries
|
||||
record? record-set! record-ref record-length
|
||||
record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output
|
||||
$make-environment
|
||||
features
|
||||
|
||||
port? input-port? output-port?
|
||||
make-input-port make-output-port make-input/output-port
|
||||
port-handler
|
||||
port-input-buffer port-input-index port-input-size
|
||||
port-output-buffer port-output-index port-output-size
|
||||
set-port-input-index! set-port-input-size!
|
||||
set-port-output-index! set-port-output-size!
|
||||
port-name input-port-name output-port-name
|
||||
write-char read-char unread-char peek-char
|
||||
newline
|
||||
reset-input-port! flush-output-port
|
||||
close-input-port close-output-port
|
||||
console-input-port current-input-port
|
||||
standard-output-port standard-error-port
|
||||
console-output-port current-output-port
|
||||
open-output-file
|
||||
open-output-string get-output-string
|
||||
with-output-to-file call-with-output-file
|
||||
with-input-from-file call-with-input-file
|
||||
|
||||
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value
|
||||
primitive-ref primitive-set!
|
||||
$fx= $fx< $fx<= $fx> $fx>= $fxzero?
|
||||
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo
|
||||
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
|
||||
$fixnum->char $char->fixnum
|
||||
$char= $char< $char<= $char> $char>=
|
||||
$car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
|
||||
$make-symbol $set-symbol-plist! $symbol-plist
|
||||
$sc-put-cte
|
||||
$record? $record/rtd? $record-set! $record-ref $record-rtd
|
||||
$make-record $record
|
||||
$base-rtd
|
||||
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
|
||||
$code->closure list*->code*
|
||||
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
code-size code-ref code-set!
|
||||
$frame->continuation $fp-at-base $current-frame $seal-frame-and-call
|
||||
$make-call-with-values-procedure $make-values-procedure
|
||||
do-overflow collect
|
||||
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
|
||||
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
|
||||
call/cf trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string date-string
|
||||
vector-memq vector-memv
|
||||
|
||||
;;; must open-code
|
||||
$make-port
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler
|
||||
$port-input-buffer $port-input-index $port-input-size
|
||||
$port-output-buffer $port-output-index $port-output-size
|
||||
$set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
|
||||
;;; better open-code
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
|
||||
;;; never open-code
|
||||
$reset-input-port! $close-input-port
|
||||
$close-output-port $flush-output-port
|
||||
*standard-output-port* *standard-error-port* *current-output-port*
|
||||
*standard-input-port* *current-input-port*
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(#%date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.6.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" #t "libcollect.fasl"]
|
||||
["librecord-6.4.ss" #t "librecord.fasl"]
|
||||
["libcxr-6.0.ss" #t "libcxr.fasl"]
|
||||
["libcore-6.9.ss" #t "libcore.fasl"]
|
||||
["libchezio-8.1.ss" #t "libchezio.fasl"]
|
||||
["libwriter-6.2.ss" #t "libwriter.fasl"]
|
||||
["libtokenizer-6.1.ss" #t "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" #t "libassembler.ss"]
|
||||
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" #t "libfasl.fasl"]
|
||||
["libcompile-8.1.ss" #t "libcompile.fasl"]
|
||||
["psyntax-7.1-6.9.ss" #t "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" #t "libcafe.fasl"]
|
||||
["libtrace-6.9.ss" #t "libtrace.fasl"]
|
||||
["libposix-6.0.ss" #t "libposix.fasl"]
|
||||
["libhash-6.2.ss" #t "libhash.fasl"]
|
||||
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)
|
||||
(printf "done\n")))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (cadr x)
|
||||
(compile-library (car x) (caddr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.fasl"
|
||||
(join " " (map caddr scheme-library-files))))
|
|
@ -48,7 +48,12 @@ sub gen3{
|
|||
}
|
||||
}
|
||||
|
||||
gen1 "movb \$0, 4(r1)\n";
|
||||
gen1 "movl \$0x1234, r1\n";
|
||||
|
||||
#gen1 "movl \$27, 4(r1)\n";
|
||||
#gen1 "movl \$27, 4000(r1)\n";
|
||||
|
||||
#gen1 "movb \$0, 4(r1)\n";
|
||||
#gen1 "movb -2(r1), %ah\n";
|
||||
|
||||
#gen2 "xorl r1,r2\n";
|
||||
|
|
|
@ -4,11 +4,11 @@ tmp.o: file format elf32-i386
|
|||
Disassembly of section .text:
|
||||
|
||||
00000000 <.text>:
|
||||
0: c6 40 04 00 movb $0x0,0x4(%eax)
|
||||
4: c6 41 04 00 movb $0x0,0x4(%ecx)
|
||||
8: c6 42 04 00 movb $0x0,0x4(%edx)
|
||||
c: c6 43 04 00 movb $0x0,0x4(%ebx)
|
||||
10: c6 44 24 04 00 movb $0x0,0x4(%esp)
|
||||
15: c6 45 04 00 movb $0x0,0x4(%ebp)
|
||||
19: c6 46 04 00 movb $0x0,0x4(%esi)
|
||||
1d: c6 47 04 00 movb $0x0,0x4(%edi)
|
||||
0: b8 34 12 00 00 mov $0x1234,%eax
|
||||
5: b9 34 12 00 00 mov $0x1234,%ecx
|
||||
a: ba 34 12 00 00 mov $0x1234,%edx
|
||||
f: bb 34 12 00 00 mov $0x1234,%ebx
|
||||
14: bc 34 12 00 00 mov $0x1234,%esp
|
||||
19: bd 34 12 00 00 mov $0x1234,%ebp
|
||||
1e: be 34 12 00 00 mov $0x1234,%esi
|
||||
23: bf 34 12 00 00 mov $0x1234,%edi
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
.text
|
||||
movb $0, 4(%eax)
|
||||
movb $0, 4(%ecx)
|
||||
movb $0, 4(%edx)
|
||||
movb $0, 4(%ebx)
|
||||
movb $0, 4(%esp)
|
||||
movb $0, 4(%ebp)
|
||||
movb $0, 4(%esi)
|
||||
movb $0, 4(%edi)
|
||||
movl $0x1234, %eax
|
||||
movl $0x1234, %ecx
|
||||
movl $0x1234, %edx
|
||||
movl $0x1234, %ebx
|
||||
movl $0x1234, %esp
|
||||
movl $0x1234, %ebp
|
||||
movl $0x1234, %esi
|
||||
movl $0x1234, %edi
|
||||
|
|
BIN
src/ikarus.fasl
BIN
src/ikarus.fasl
Binary file not shown.
|
@ -0,0 +1,56 @@
|
|||
|
||||
(primitive-set! 'make-code
|
||||
(lambda (code-size freevars)
|
||||
(unless (and (fixnum? code-size) ($fx>= code-size 0))
|
||||
(error 'make-code "~s is not a valid code size" code-size))
|
||||
(unless (and (fixnum? freevars) ($fx>= freevars 0))
|
||||
(error 'make-code "~s is not a valid number of free vars" freevars))
|
||||
(foreign-call "ikrt_make_code" code-size freevars '#())))
|
||||
|
||||
(primitive-set! 'code?
|
||||
(lambda (x) ($code? x)))
|
||||
|
||||
(primitive-set! 'code-reloc-vector
|
||||
(lambda (x)
|
||||
(unless ($code? x) (error 'code-reloc-vector "~s is not a code" x))
|
||||
($code-reloc-vector x)))
|
||||
|
||||
(primitive-set! 'code-freevars
|
||||
(lambda (x)
|
||||
(unless ($code? x) (error 'code-closure-size "~s is not a code" x))
|
||||
($code-freevars x)))
|
||||
|
||||
(primitive-set! 'code-size
|
||||
(lambda (x)
|
||||
(unless ($code? x) (error 'code-size "~s is not a code" x))
|
||||
($code-size x)))
|
||||
|
||||
(primitive-set! 'code-set!
|
||||
(lambda (x i v)
|
||||
(unless ($code? x) (error 'code-set! "~s is not a code" x))
|
||||
(unless (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fx< i ($code-size x)))
|
||||
(error 'code-set! "~s is not a valid index" i))
|
||||
(unless (and (fixnum? v)
|
||||
($fx>= v 0)
|
||||
($fx< v 256))
|
||||
(error 'code-set! "~s is not a valid byte" v))
|
||||
($code-set! x i v)))
|
||||
|
||||
(primitive-set! 'code-ref
|
||||
(lambda (x i)
|
||||
(unless ($code? x) (error 'code-ref "~s is not a code" x))
|
||||
(unless (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fx< i ($code-size x)))
|
||||
(error 'code-ref "~s is not a valid index" i))
|
||||
($code-ref x i)))
|
||||
|
||||
(primitive-set! 'set-code-reloc-vector!
|
||||
(lambda (x v)
|
||||
(unless ($code? x)
|
||||
(error 'set-code-reloc-vector! "~s is not a code" x))
|
||||
(unless (vector? v)
|
||||
(error 'set-code-reloc-vector! "~s is not a vector" v))
|
||||
(foreign-call "ikrt_set_code_reloc_vector" x v)))
|
|
@ -1,56 +1,67 @@
|
|||
|
||||
(define-record code (closure-size code-vec reloc-vec))
|
||||
|
||||
(define make-code
|
||||
(let ([make-code make-code])
|
||||
(let ()
|
||||
(define-record code (closure-size code-vec reloc-vec))
|
||||
|
||||
(define make-code^
|
||||
(lambda (code-size reloc-size closure-size)
|
||||
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
|
||||
(make-code
|
||||
closure-size
|
||||
(make-string code-size (integer->char 0))
|
||||
(make-vector (fxsra reloc-size 2)))))))
|
||||
(make-vector (fxsra reloc-size 2))))))
|
||||
|
||||
(define set-code-byte!
|
||||
(lambda (code idx byte)
|
||||
(string-set! (code-code-vec code) idx (integer->char byte))))
|
||||
|
||||
(define set-code-word!
|
||||
(lambda (code idx x)
|
||||
(cond
|
||||
[(fixnum? x)
|
||||
(set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
|
||||
(set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
|
||||
(set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
|
||||
(set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
|
||||
[else (error 'set-code-word! "unhandled ~s" x)])))
|
||||
|
||||
(define set-code-object!
|
||||
(lambda (code obj code-idx reloc-idx)
|
||||
(let ([v (code-reloc-vec code)])
|
||||
(vector-set! v reloc-idx (list 'object code-idx obj)))))
|
||||
|
||||
(define set-code-foreign-object!
|
||||
(lambda (code obj code-idx reloc-idx)
|
||||
(let ([v (code-reloc-vec code)])
|
||||
(vector-set! v reloc-idx (list 'foreign code-idx obj))
|
||||
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
|
||||