autocompile works for guile 3.0.0

parent a66e5ab6
......@@ -3,6 +3,8 @@
#:use-module (ice-9 control)
#:use-module (oop pf-objects)
#:use-module (oop goops)
#:use-module ((oop dict) #:select (leveler))
#:use-module (system syntax internal)
#:use-module (rnrs bytevectors)
#:use-module (language python guilemod)
#:use-module (language python dict)
......@@ -45,6 +47,56 @@
(define-inlinable (H x) `(@ (language python hash) ,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 (mk/ec x) x)
......@@ -286,7 +338,7 @@ empty list."
(fold f (f (car l) init) (cdr l))
init))
(define do-pr #f)
(define do-pr #t)
(define (pr . x)
(if do-pr
......@@ -979,12 +1031,17 @@ empty list."
(define lr-or (lr `((#:bor . ,(mklr (N 'py-logior))))))
(define lr-and (lr `((#:band . ,(mklr (N 'py-logand))))))
(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 ...) ...)
(begin
(hash-set! tagis tag
(lambda (x vs)
(match x code ...)))
(lambda (x vs n m)
(syntax-parameterize
((N (lambda (x) #'n))
(M (lambda (x) #'m)))
(match x code ...))))
...))
......@@ -1220,7 +1277,8 @@ empty list."
((_ . l) (cons (G 'begin) (map (g vs exp) l))))
(#:classdef
((_ class parents code)
((_ class parents code)
(vector
(with-fluids ((is-class? (exp vs class)))
(let ()
(define (clean l)
......@@ -1258,7 +1316,7 @@ empty list."
`(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
,doc
,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
,cd)))))))))
,cd))))))))))
(#:verb
((_ x) x))
......@@ -1771,6 +1829,7 @@ empty list."
(#:types-args-list . args)
#f
code)
(vector
(let* ((decor (let ((r (fluid-ref decorations)))
(fluid-set! decorations '())
r))
......@@ -1818,8 +1877,8 @@ empty list."
(if y?
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor
(,(C 'def-wrap) ,y? ,f ,ab
`(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
......@@ -1828,7 +1887,7 @@ empty list."
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor
`(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
......@@ -1838,8 +1897,8 @@ empty list."
(if y?
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor
(,(C 'def-wrap) ,y? ,f ,ab
`(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
......@@ -1847,12 +1906,12 @@ empty list."
,(mk cd)))))))))
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor
`(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(mk cd)))))))))))))
,(mk cd))))))))))))))
(#:global
((_ . _)
......@@ -1900,14 +1959,16 @@ empty list."
(#:lambdef
((_ (#:var-args-list . v) e)
(vector
(let ((as (get-args_ vs v))
(a= (get-args= vs v))
(a* (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)
(list (C `lam) `() (exp vs e))))
(vector
(list (C `lam) `() (exp vs e)))))
(#:stmt
((_ l)
......@@ -2115,14 +2176,20 @@ empty list."
,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
(define (exp vs x)
(define (exp vs x)
(match (pr 'exp x)
((e)
(exp vs e))
((tag . l)
((hash-ref tagis tag
(lambda y (warn (format #f "not tag in tagis ~a" tag)) x))
x vs))
(let ((ll (get-pos x)))
(pos
(apply (hash-ref tagis tag
(lambda y
(warn (format #f "not tag in tagis ~a" tag)) x))
x vs ll)
x)))
(#:True #t)
(#:None (E 'None))
......@@ -2203,6 +2270,7 @@ empty list."
(format #t "~s~%" (car x))
(lp (cdr x)))))))))
(define moddef #f)
(define args
(match x
(((#:stmt
......@@ -2214,6 +2282,7 @@ empty list."
((#:arglist arglist))
. #f) #f))
(#:assign)))) . rest)
(set! moddef #t)
(cons
(map (lambda (x)
(exp '() x))
......@@ -2258,7 +2327,7 @@ empty list."
(set! s/d (C 'qset!))
(set! s/d (C 'define-)))
(if (pair? start)
(if moddef
(set! x (cdr x)))
(let* ((globs (get-globals x))
......@@ -2267,7 +2336,7 @@ empty list."
(cons r (get-doc)))))
(e (car e.doc))
(doc (cdr e.doc)))
`(,@start
,(if (pair? start)
`(,(G 'if) *main*
......@@ -2906,11 +2975,12 @@ empty list."
(define-syntax def-wrap
(lambda (x)
(syntax-case x ()
((_ #f f ab x)
#'x)
((_ #f f ab n m x)
#'(NR n m x))
((_ #t f ab code)
#'(lambda x
((_ #t f ab n m code)
#'(NR n m
(lambda x
(define obj (make <yield>))
(define ab (make-prompt-tag))
(slot-set! obj 'k #f)
......@@ -2936,7 +3006,7 @@ empty list."
lam)))
(apply values l))))
lam))))
obj)))))
obj))))))
(define miss (list 'miss))
(define-inlinable (wr o k x)
......@@ -3046,9 +3116,9 @@ empty list."
(define-syntax def-decor
(syntax-rules ()
((_ () x) x)
((_ (f ... r) y)
(def-decor (f ...) (r y)))))
((_ () n m x) (NR n m x))
((_ (f ... r) n m y)
(def-decor (f ...) n m (r y)))))
(define-syntax with-self
(syntax-rules ()
......
(define-module (language python def)
#:use-module (ice-9 pretty-print)
#:use-module (system syntax internal)
#: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 (ice-9 match)
#:use-module (srfi srfi-11)
......@@ -83,11 +84,12 @@
(kv (fold get-kv '() #'(arg ...))))
(if (and-map null? (list kw ww- kv))
#`(object-method
(lambda (#,@as . u12345678)
(leveler
(lambda (#,@as . u12345678)
(if (and (pair? u12345678)
(not (keyword? (car u12345678))))
(raise (ArgumentError "too many arguments to function")))
(let () code ...)))
(let () code ...))))
(with-syntax ((kw (if (null? kw)
(datum->syntax x (gensym "kw"))
(car kw)))
......@@ -98,7 +100,8 @@
((s ...) (map ->kw (map car kv)))
((v ...) (map cdr kv)))
#`(object-method
(lambda* (#,@as . l)
#,(trstx x
#`(lambda* (#,@as . l)
(call-with-values (lambda () (get-akw l))
(lambda (ww* kw)
(let*-values (((ww* k) (take-1 #,(null? ww-) ww*
......@@ -106,7 +109,7 @@
...)
(let ((ww ww*)
(kw (pytonize kw)))
(let () code ...))))))))))))))
(let () code ...)))))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
......
(define-module (language python guilemod)
#:use-module (system base message)
#:use-module (system foreign)
#: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 %eval-no-warn (make-hash-table))
......@@ -74,7 +85,6 @@
(env ((C default-environment) from))
(opts '())
(canonicalization 'relative))
(with-fluids (((C %in-compile ) #t )
((C %in-file ) file )
(%dont-warn-list '() )
......@@ -295,27 +305,124 @@ property alist) using the data in ARGS."
(M %warning-types))))
))
(define pload
(let ((guile-load (@ (guile) primitive-load-path)))
(lambda (p . q)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(guile-load p (lambda () (abort-to-prompt tag))))
(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 guile-load (@@ (guile) primitive-load-path))
(cond-expand
(guile-3.0
(define (more-recent? stat1 stat2)
;; Return #t when STAT1 has an mtime greater than that of STAT2.
(or (> (stat:mtime stat1) (stat:mtime stat2))
(and (= (stat:mtime stat1) (stat:mtime stat2))
(>= (stat:mtimensec stat1)
(stat:mtimensec stat2)))))
(define (canonical->suffix canon)
(cond
((and (not (string-null? canon))
((@@ (guile) file-name-separator?) (string-ref canon 0)))
canon)
((and (eq? ((@@ (guile) system-file-name-convention)) 'windows)
((@@ (guile) absolute-file-name?) canon))
;; An absolute file name that doesn't start with a separator
;; starts with a drive component. Transform the drive component
;; 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