autocompile works for guile 3.0.0

parent a66e5ab6
...@@ -3,6 +3,8 @@ ...@@ -3,6 +3,8 @@
#:use-module (ice-9 control) #:use-module (ice-9 control)
#:use-module (oop pf-objects) #:use-module (oop pf-objects)
#:use-module (oop goops) #:use-module (oop goops)
#:use-module ((oop dict) #:select (leveler))
#:use-module (system syntax internal)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (language python guilemod) #:use-module (language python guilemod)
#:use-module (language python dict) #:use-module (language python dict)
...@@ -45,6 +47,56 @@ ...@@ -45,6 +47,56 @@
(define-inlinable (H x) `(@ (language python hash) ,x)) (define-inlinable (H x) `(@ (language python hash) ,x))
(define-inlinable (W x) `(@ (language python with) ,x)) (define-inlinable (W x) `(@ (language python with) ,x))
(cond-expand
(guile-2.2
(define (set-position stx line col)
(let ((r (syntax-expression stx)))
(pk 1 line col (source-properties r))
(set-source-property! r 'line line)
(set-source-property! r 'column col)
(pk 2 line col (source-properties r))
stx))
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ line col stx)
#t
(begin
(set-position #'stx (syntax->datum #'col) (syntax->datum #'line))
#'stx))))))
(guile-2.0
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ line col stx)
#t
#'stx))))))
(define (get-pos y)
(aif it (object-property y 'position)
`(,(car it) ,(cdr it))
(list 0 0)))
(define (pos x y)
(if (vector? x)
(let ((x (vector-ref x 0)))
(if (pair? x)
(aif it (object-property y 'position)
`(,(C 'NR) ,(car it) ,(cdr it) ,x)
x)
x))
x))
(cond-expand
(guile-3.0
(define (not-inline x) (leveler x)))
(guile-2.0
(define-syntax not-inline (syntax-rules () ((_ x) x)))))
(define in-dec (make-fluid #f)) (define in-dec (make-fluid #f))
(define (mk/ec x) x) (define (mk/ec x) x)
...@@ -286,7 +338,7 @@ empty list." ...@@ -286,7 +338,7 @@ empty list."
(fold f (f (car l) init) (cdr l)) (fold f (f (car l) init) (cdr l))
init)) init))
(define do-pr #f) (define do-pr #t)
(define (pr . x) (define (pr . x)
(if do-pr (if do-pr
...@@ -979,12 +1031,17 @@ empty list." ...@@ -979,12 +1031,17 @@ empty list."
(define lr-or (lr `((#:bor . ,(mklr (N 'py-logior)))))) (define lr-or (lr `((#:bor . ,(mklr (N 'py-logior))))))
(define lr-and (lr `((#:band . ,(mklr (N 'py-logand)))))) (define lr-and (lr `((#:band . ,(mklr (N 'py-logand))))))
(define lr-xor (lr `((#:bxor . ,(mklr (N 'py-logxor)))))) (define lr-xor (lr `((#:bxor . ,(mklr (N 'py-logxor))))))
(define-syntax-parameter N (lambda (x) 0))
(define-syntax-parameter M (lambda (x) 0))
(define-syntax-rule (gen-table x vs (tag code ...) ...) (define-syntax-rule (gen-table x vs (tag code ...) ...)
(begin (begin
(hash-set! tagis tag (hash-set! tagis tag
(lambda (x vs) (lambda (x vs n m)
(match x code ...))) (syntax-parameterize
((N (lambda (x) #'n))
(M (lambda (x) #'m)))
(match x code ...))))
...)) ...))
...@@ -1220,7 +1277,8 @@ empty list." ...@@ -1220,7 +1277,8 @@ empty list."
((_ . l) (cons (G 'begin) (map (g vs exp) l)))) ((_ . l) (cons (G 'begin) (map (g vs exp) l))))
(#:classdef (#:classdef
((_ class parents code) ((_ class parents code)
(vector
(with-fluids ((is-class? (exp vs class))) (with-fluids ((is-class? (exp vs class)))
(let () (let ()
(define (clean l) (define (clean l)
...@@ -1258,7 +1316,7 @@ empty list." ...@@ -1258,7 +1316,7 @@ empty list."
`(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ()))) `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
,doc ,doc
,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls) ,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
,cd))))))))) ,cd))))))))))
(#:verb (#:verb
((_ x) x)) ((_ x) x))
...@@ -1771,6 +1829,7 @@ empty list." ...@@ -1771,6 +1829,7 @@ empty list."
(#:types-args-list . args) (#:types-args-list . args)
#f #f
code) code)
(vector
(let* ((decor (let ((r (fluid-ref decorations))) (let* ((decor (let ((r (fluid-ref decorations)))
(fluid-set! decorations '()) (fluid-set! decorations '())
r)) r))
...@@ -1818,8 +1877,8 @@ empty list." ...@@ -1818,8 +1877,8 @@ empty list."
(if y? (if y?
`(set! ,f `(set! ,f
,(docer ,(docer
`(,(C 'def-decor) ,decor `(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab (,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa (,(D 'lam) ,aa
(,(C 'with-return) ,r (,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
...@@ -1828,7 +1887,7 @@ empty list." ...@@ -1828,7 +1887,7 @@ empty list."
`(set! ,f `(set! ,f
,(docer ,(docer
`(,(C 'def-decor) ,decor `(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa (,(D 'lam) ,aa
(,(C 'with-return) ,r (,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
...@@ -1838,8 +1897,8 @@ empty list." ...@@ -1838,8 +1897,8 @@ empty list."
(if y? (if y?
`(set! ,f `(set! ,f
,(docer ,(docer
`(,(C 'def-decor) ,decor `(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab (,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa (,(D 'lam) ,aa
(,(C 'with-return) ,r (,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls) (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
...@@ -1847,12 +1906,12 @@ empty list." ...@@ -1847,12 +1906,12 @@ empty list."
,(mk cd))))))))) ,(mk cd)))))))))
`(set! ,f `(set! ,f
,(docer ,(docer
`(,(C 'def-decor) ,decor `(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa (,(D 'lam) ,aa
(,(C 'with-return) ,r (,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls) (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa (,(C 'with-self) ,c? ,aa
,(mk cd))))))))))))) ,(mk cd))))))))))))))
(#:global (#:global
((_ . _) ((_ . _)
...@@ -1900,14 +1959,16 @@ empty list." ...@@ -1900,14 +1959,16 @@ empty list."
(#:lambdef (#:lambdef
((_ (#:var-args-list . v) e) ((_ (#:var-args-list . v) e)
(vector
(let ((as (get-args_ vs v)) (let ((as (get-args_ vs v))
(a= (get-args= vs v)) (a= (get-args= vs v))
(a* (get-args* vs v)) (a* (get-args* vs v))
(** (get-args** vs v))) (** (get-args** vs v)))
(list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))) (list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))))
((_ () e) ((_ () e)
(list (C `lam) `() (exp vs e)))) (vector
(list (C `lam) `() (exp vs e)))))
(#:stmt (#:stmt
((_ l) ((_ l)
...@@ -2115,14 +2176,20 @@ empty list." ...@@ -2115,14 +2176,20 @@ empty list."
,(exp vs `(#:comp (#:verb ,m) . ,l)))))))) ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
(define (exp vs x) (define (exp vs x)
(match (pr 'exp x) (match (pr 'exp x)
((e) ((e)
(exp vs e)) (exp vs e))
((tag . l) ((tag . l)
((hash-ref tagis tag (let ((ll (get-pos x)))
(lambda y (warn (format #f "not tag in tagis ~a" tag)) x)) (pos
x vs)) (apply (hash-ref tagis tag
(lambda y
(warn (format #f "not tag in tagis ~a" tag)) x))
x vs ll)
x)))
(#:True #t) (#:True #t)
(#:None (E 'None)) (#:None (E 'None))
...@@ -2203,6 +2270,7 @@ empty list." ...@@ -2203,6 +2270,7 @@ empty list."
(format #t "~s~%" (car x)) (format #t "~s~%" (car x))
(lp (cdr x))))))))) (lp (cdr x)))))))))
(define moddef #f)
(define args (define args
(match x (match x
(((#:stmt (((#:stmt
...@@ -2214,6 +2282,7 @@ empty list." ...@@ -2214,6 +2282,7 @@ empty list."
((#:arglist arglist)) ((#:arglist arglist))
. #f) #f)) . #f) #f))
(#:assign)))) . rest) (#:assign)))) . rest)
(set! moddef #t)
(cons (cons
(map (lambda (x) (map (lambda (x)
(exp '() x)) (exp '() x))
...@@ -2258,7 +2327,7 @@ empty list." ...@@ -2258,7 +2327,7 @@ empty list."
(set! s/d (C 'qset!)) (set! s/d (C 'qset!))
(set! s/d (C 'define-))) (set! s/d (C 'define-)))
(if (pair? start) (if moddef
(set! x (cdr x))) (set! x (cdr x)))
(let* ((globs (get-globals x)) (let* ((globs (get-globals x))
...@@ -2267,7 +2336,7 @@ empty list." ...@@ -2267,7 +2336,7 @@ empty list."
(cons r (get-doc))))) (cons r (get-doc)))))
(e (car e.doc)) (e (car e.doc))
(doc (cdr e.doc))) (doc (cdr e.doc)))
`(,@start `(,@start
,(if (pair? start) ,(if (pair? start)
`(,(G 'if) *main* `(,(G 'if) *main*
...@@ -2906,11 +2975,12 @@ empty list." ...@@ -2906,11 +2975,12 @@ empty list."
(define-syntax def-wrap (define-syntax def-wrap
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ #f f ab x) ((_ #f f ab n m x)
#'x) #'(NR n m x))
((_ #t f ab code) ((_ #t f ab n m code)
#'(lambda x #'(NR n m
(lambda x
(define obj (make <yield>)) (define obj (make <yield>))
(define ab (make-prompt-tag)) (define ab (make-prompt-tag))
(slot-set! obj 'k #f) (slot-set! obj 'k #f)
...@@ -2936,7 +3006,7 @@ empty list." ...@@ -2936,7 +3006,7 @@ empty list."
lam))) lam)))
(apply values l)))) (apply values l))))
lam)))) lam))))
obj))))) obj))))))
(define miss (list 'miss)) (define miss (list 'miss))
(define-inlinable (wr o k x) (define-inlinable (wr o k x)
...@@ -3046,9 +3116,9 @@ empty list." ...@@ -3046,9 +3116,9 @@ empty list."
(define-syntax def-decor (define-syntax def-decor
(syntax-rules () (syntax-rules ()
((_ () x) x) ((_ () n m x) (NR n m x))
((_ (f ... r) y) ((_ (f ... r) n m y)
(def-decor (f ...) (r y))))) (def-decor (f ...) n m (r y)))))
(define-syntax with-self (define-syntax with-self
(syntax-rules () (syntax-rules ()
......
(define-module (language python def) (define-module (language python def)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (system syntax internal)
#:use-module (oop pf-objects) #:use-module (oop pf-objects)
#:use-module ((oop dict) #:select (hset! mkw to-list)) #:use-module ((oop dict) #:select (hset! mkw to-list leveler))
#:use-module (language python exceptions) #:use-module (language python exceptions)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
...@@ -83,11 +84,12 @@ ...@@ -83,11 +84,12 @@
(kv (fold get-kv '() #'(arg ...)))) (kv (fold get-kv '() #'(arg ...))))
(if (and-map null? (list kw ww- kv)) (if (and-map null? (list kw ww- kv))
#`(object-method #`(object-method
(lambda (#,@as . u12345678) (leveler
(lambda (#,@as . u12345678)
(if (and (pair? u12345678) (if (and (pair? u12345678)
(not (keyword? (car u12345678)))) (not (keyword? (car u12345678))))
(raise (ArgumentError "too many arguments to function"))) (raise (ArgumentError "too many arguments to function")))
(let () code ...))) (let () code ...))))
(with-syntax ((kw (if (null? kw) (with-syntax ((kw (if (null? kw)
(datum->syntax x (gensym "kw")) (datum->syntax x (gensym "kw"))
(car kw))) (car kw)))
...@@ -98,7 +100,8 @@ ...@@ -98,7 +100,8 @@
((s ...) (map ->kw (map car kv))) ((s ...) (map ->kw (map car kv)))
((v ...) (map cdr kv))) ((v ...) (map cdr kv)))
#`(object-method #`(object-method
(lambda* (#,@as . l) #,(trstx x
#`(lambda* (#,@as . l)
(call-with-values (lambda () (get-akw l)) (call-with-values (lambda () (get-akw l))
(lambda (ww* kw) (lambda (ww* kw)
(let*-values (((ww* k) (take-1 #,(null? ww-) ww* (let*-values (((ww* k) (take-1 #,(null? ww-) ww*
...@@ -106,7 +109,7 @@ ...@@ -106,7 +109,7 @@
...) ...)
(let ((ww ww*) (let ((ww ww*)
(kw (pytonize kw))) (kw (pytonize kw)))
(let () code ...)))))))))))))) (let () code ...)))))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...))) (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
......
(define-module (language python guilemod) (define-module (language python guilemod)
#:use-module (system base message) #:use-module (system base message)
#:use-module (system foreign)
#:export (%add-to-warn-list %dont-warn-list %eval-no-warn)) #:export (%add-to-warn-list %dont-warn-list %eval-no-warn))
(define-syntax-rule (defineu f a x)
(begin
(define f
(catch #t
(lambda () x)
(lambda z
(let ((message (format #f "could not define ~a" 'f)))
(warn message)
(lambda z (error message))))))))
(define-syntax-rule (aif it p . l) (let ((it p)) (if it . l))) (define-syntax-rule (aif it p . l) (let ((it p)) (if it . l)))
(define %eval-no-warn (make-hash-table)) (define %eval-no-warn (make-hash-table))
...@@ -74,7 +85,6 @@ ...@@ -74,7 +85,6 @@
(env ((C default-environment) from)) (env ((C default-environment) from))
(opts '()) (opts '())
(canonicalization 'relative)) (canonicalization 'relative))
(with-fluids (((C %in-compile ) #t ) (with-fluids (((C %in-compile ) #t )
((C %in-file ) file ) ((C %in-file ) file )
(%dont-warn-list '() ) (%dont-warn-list '() )
...@@ -295,27 +305,124 @@ property alist) using the data in ARGS." ...@@ -295,27 +305,124 @@ property alist) using the data in ARGS."
(M %warning-types)))) (M %warning-types))))
)) ))
(define pload (define guile-load (@@ (guile) primitive-load-path))
(let ((guile-load (@ (guile) primitive-load-path)))
(lambda (p . q) (cond-expand
(let ((tag (make-prompt-tag))) (guile-3.0
(call-with-prompt (define (more-recent? stat1 stat2)
tag ;; Return #t when STAT1 has an mtime greater than that of STAT2.
(lambda () (or (> (stat:mtime stat1) (stat:mtime stat2))
(guile-load p (lambda () (abort-to-prompt tag)))) (and (= (stat:mtime stat1) (stat:mtime stat2))
(lambda (k) (>= (stat:mtimensec stat1)
(let lp ((l *extension-dispatches*)) (stat:mtimensec stat2)))))
(if (pair? l)
(let lp2 ((u (caar l))) (define (canonical->suffix canon)
(if (pair? u) (cond
(aif it (%search-load-path ((and (not (string-null? canon))
(string-append p "." (car u))) ((@@ (guile) file-name-separator?) (string-ref canon 0)))
(apply guile-load it q) canon)
(lp2 (cdr u))) ((and (eq? ((@@ (guile) system-file-name-convention)) 'windows)
(lp (cdr l)))) ((@@ (guile) absolute-file-name?) canon))
(if (pair? q) ;; An absolute file name that doesn't start with a separator
((car q)) ;; starts with a drive component. Transform the drive component
(error (string-append "no code for path " p))))))))))) ;; to a file name element: c:\foo -> \c\foo.
(string-append (@@ (guile) file-name-separator-string)
(substring canon 0 1)
(substring canon 2)))
(else canon)))
(define compiled-extension
;; File name extension of compiled files.
(cond ((or (null? (@@ (guile) %load-compiled-extensions))
(string-null? (car (@@ (guile) %load-compiled-extensions))))
(warn "invalid %load-compiled-extensions"
(@@ (guile) %load-compiled-extensions))
".go")
(else (car (@@ (guile) %load-compiled-extensions)))))
(define (fallback-file-name canon-file-name)
;; Return the in-cache compiled file name for source file
;; CANON-FILE-NAME.
;; FIXME: would probably be better just to append
;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid
;; deep directory stats.
(and (@@ (guile) %compile-fallback-path)
(string-append (@@ (guile) %compile-fallback-path)
(canonical->suffix canon-file-name)
compiled-extension)))
(define (get-go abs-file-name)
(and=> ((@@ (guile) false-if-exception)
((@@ (guile) canonicalize-path) abs-file-name))
(lambda (canon)
(and=> (fallback-file-name canon)
(lambda (go-file-name) go-file-name)))))
(define (docompile? name)
(let ((scmstat (stat name #f))
(gostat (stat (get-go name) #f)))
(if scmstat
(not
(and gostat scmstat (more-recent? gostat scmstat)))
#f)))
(define pload
(lambda (p . q)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(let lp ((l *extension-dispatches*))
(if (pair? l)
(let lp2 ((u (caar l)))
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(begin
(when (docompile? it)
((@ (system base compile) compile-file) it))
(apply guile-load it q))
(lp2 (cdr u)))
(lp (cdr l))))
(apply guile-load p q))))
(lambda (k)
(let lp ((l *extension-dispatches*))
(if (pair? l)
(let lp2 ((u (caar l)))
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(begin
((@ (system base compile) compile-file) it)
(apply guile-load it q))
(lp2 (cdr u)))
(lp (cdr l))))
(if (pair? q)
((car q))
(error (string-append "no code for path " p)))))))))))
(guile-2.0
(define pload
(lambda (p . q)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(apply guile-load p q))
(lambda (k)
(let lp ((l *extension-dispatches*))
(if (pair? l)
(let lp2 ((u (caar l)))
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(apply guile-load it q)
(lp2 (cdr u)))
(lp (cdr l))))
(if (pair? q)
((car q))
(error (string-append "no code for path " p))))))))))))
(define-set-G primitive-load-path pload) (define-set-G primitive-load-path pload)
module(a) def f(x):
g(x)
raise
def g(x):
if x:
raise
raise
from . import a
from .x import a
(define-module (language python module a)
#:export (a))
(define a 1)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment