conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* fixed a pretty-printer bug that caused gensym count to be assigned 

out of order.  It now uses map1ltr instead of map for list
  processing.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-03 04:38:48 -04:00
parent b6734896e2
commit bf3e5711a9
3 changed files with 51 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

16
src/libpp.ss
View File

@ -2,7 +2,13 @@
(library (ikarus pretty-print) (library (ikarus pretty-print)
(export) (export)
(import (scheme)) (import (scheme))
(define (map1ltr f ls)
;;; ltr so that gensym counts get assigned properly
(cond
[(null? ls) '()]
[else
(let ([a (f (car ls))])
(cons a (map1ltr f (cdr ls))))]))
(define (pretty-width) 80) (define (pretty-width) 80)
(define (pretty-indent) 1) (define (pretty-indent) 1)
(define-record cbox (length boxes)) (define-record cbox (length boxes))
@ -138,7 +144,7 @@
(conc (cdr fmt) (boxify (cadr ls)))] (conc (cdr fmt) (boxify (cadr ls)))]
[(fmt-dots? fmt) [(fmt-dots? fmt)
(return (fmt-tab fmt) (return (fmt-tab fmt)
(map (lambda (x) (boxify/fmt (sub-fmt fmt) x)) (map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
ls))] ls))]
[else [else
(let-values ([(sep* ls) (let-values ([(sep* ls)
@ -148,7 +154,7 @@
(values '() '())] (values '() '())]
[(fmt-dots? fmt) [(fmt-dots? fmt)
(values (fmt-tab fmt) (values (fmt-tab fmt)
(map (lambda (x) (map1ltr (lambda (x)
(boxify/fmt (sub-fmt fmt) x)) (boxify/fmt (sub-fmt fmt) x))
ls))] ls))]
[else [else
@ -161,7 +167,7 @@
l^)))]))]) l^)))]))])
(return sep* (cons (boxify/fmt (sub-fmt fmt) a) ls)))])))] (return sep* (cons (boxify/fmt (sub-fmt fmt) a) ls)))])))]
[else [else
(return (gensep*-default ls) (map boxify ls))]))) (return (gensep*-default ls) (map1ltr boxify ls))])))
(define (boxify-string x) (define (boxify-string x)
(define (count s i j n) (define (count s i j n)
(cond (cond
@ -202,7 +208,7 @@
(fx+ (fxadd1 n) (box-length (car ls))))]))]) (fx+ (fxadd1 n) (box-length (car ls))))]))])
(make-pbox (fx+ n (box-length last)) ls last)))) (make-pbox (fx+ n (box-length last)) ls last))))
(define (boxify-vector x) (define (boxify-vector x)
(let ([ls (map boxify (vector->list x))]) (let ([ls (map1ltr boxify (vector->list x))])
(let ([n (let ([n
(let f ([ls ls] [n 0]) (let f ([ls ls] [n 0])
(cond (cond

92
src/makefile.ss
View File

@ -124,44 +124,50 @@
[(null? r) '()] [(null? r) '()]
[else (add (car r) (f (cdr r)))]))) [else (add (car r) (f (cdr r)))])))
(define (make-system-library export-subst export-env) (define (build-system-library export-subst export-env)
`(library (ikarus primlocs) (let-values ([(code empty-subst empty-env)
(export) (boot-library-expand
(import (scheme)) `(library (ikarus primlocs)
(install-library (export) ;;; must be empty
',(gensym "system") ;;; id (import (scheme))
'(system) ;;; name (install-library
'() ;;; version ',(gensym "system") ;;; id
'() ;;; import libs '(system) ;;; name
'() ;;; visit libs '() ;;; version
'() ;;; invoke libs '() ;;; import libs
',export-subst ;;; substitution '() ;;; visit libs
',export-env ;;; environment '() ;;; invoke libs
void void))) ',export-subst ;;; substitution
',export-env ;;; environment
void void ;;; visit/invoke codes
)))])
(pretty-print code)
code))
(define (expand-all ls)
(define (insert x ls) (define (expand-all files)
(cond ;;; insert before last library (let ([code* '()]
[(null? (cdr ls)) [subst '()]
(list x (library-code (car ls)))] [env '()])
[else (for-each
(cons (library-code (car ls)) (lambda (file)
(insert x (cdr ls)))])) (load file
(let ([libs (apply append (map expand-file ls))]) (lambda (x)
(let* ([export-subst (let-values ([(code export-subst export-env)
(apply append (map library-export-subst libs))] (boot-library-expand x)])
[export-env (set! code* (cons code code*))
(sanitize-export-env export-subst (set! subst (append export-subst subst))
(apply append (map library-export-env libs)))]) (set! env (append export-env env))))))
(let-values ([(code _subst _env) ; both must be empty files)
(boot-library-expand (let ([env (sanitize-export-env subst env)])
(make-system-library export-subst export-env))]) (let ([code (build-system-library subst env)])
(printf "EXP:~s\n" (map car export-subst)) (values
(values (insert code libs) #f))))) (reverse (list* (car code*) code (cdr code*)))
subst env)))))
(printf "expanding ...\n") (printf "expanding ...\n")
(let-values ([(core* ??env) (expand-all scheme-library-files)]) (let-values ([(core* subst env) (expand-all scheme-library-files)])
(printf "compiling ...\n") (printf "compiling ...\n")
(let ([p (open-output-file "ikarus.boot" 'replace)]) (let ([p (open-output-file "ikarus.boot" 'replace)])
(for-each (for-each
@ -172,21 +178,3 @@
(printf "Happy Happy Joy Joy\n")) (printf "Happy Happy Joy Joy\n"))
(invoke (ikarus makefile)) (invoke (ikarus makefile))
;;; ;;; NEW ARCHITECTURE
;;;
;;; (define expander-input-env
;;; '(;[prim-name label (core-prim . prim-name)]
;;; [car car-label (core-prim . car)]))
;;;
;;; (define expander-output-env
;;; '(;[export-name export-loc]
;;; [ikarus-car #{ikarus-car |174V9RJ/FjzvmJVu|}]))
;;;
;;; (define bootstrap-knot
;;; '(;[prim-name export-name]
;;; [car ikarus-car]))
;;;
;;; (define compile-input-env
;;; '(;[prim-name export-loc]
;;; [car #{ikarus-car |174V9RJ/FjzvmJVu|}]))