summaryrefslogtreecommitdiff
path: root/modules/language
diff options
context:
space:
mode:
Diffstat (limited to 'modules/language')
-rw-r--r--modules/language/python/class.scm71
-rw-r--r--modules/language/python/expr.scm106
-rw-r--r--modules/language/python/python.scm265
3 files changed, 0 insertions, 442 deletions
diff --git a/modules/language/python/class.scm b/modules/language/python/class.scm
deleted file mode 100644
index 41ed09a..0000000
--- a/modules/language/python/class.scm
+++ /dev/null
@@ -1,71 +0,0 @@
-(define-module (language python class)
- #:export (class_+ class_- class_* class_// class_%
- class_power class_<< class_>> class_ior
- class_xor class_band))
-
-(define-syntax-rule (class-ref x) (struct-ref x 0))
-(define-syntax-rule (class-num x) (struct-ref x 1))
-(define-syntax-rule (class-log x) (struct-ref x 2))
-(define-syntax-rule (class-map x) (struct-ref x 3))
-
-(define-syntax-rule (mkref +-ref n)
- (define-syntax-rule (+-ref x) (vector-ref x n)))
-
-(mkref +-ref 0)
-(mkref --ref 1)
-(mkref *-ref 2)
-(mkref /-ref 3)
-(mkref //-ref 4)
-(mkref %-ref 5)
-(mkref **-ref 6)
-(mkref <<-ref 7)
-(mkref >>-ref 8)
-
-(mkref ior-ref 0)
-(mkref xor-ref 1)
-(mkref and-ref 2)
-
-(define-syntax-rule (class-lookup class key )
- (hashq-ref (class-map class) key #f))
-
-(define-syntax-rule (meta-mk mk-num class-num)
-(define-syntax-rule (mk-num class_+ __add__ __radd__ +-ref err)
- (define (class_+ x y)
- (let* ((cl (class-ref x))
- (r (class-num cl)))
- (define (f)
- (let ((rrr (class-lookup cl '__add__)))
- (if rrr
- (rrr x y)
- (if (class? y)
- (let* ((cl (class-ref y))
- (rrrr (class-lookup cl '__radd__)))
- (if rrrr
- (rrrr y x)
- (err)))
- (err)))))
-
- (if r
- (let ((rr (+-ref r)))
- (if rr
- (rr x y)
- (f)))
- (f))))))
-
-(meta-mk mk-num class-num)
-(meta-mk mk-log class-log)
-
-(define (err) (error "could not do artithmetic ops"))
-
-(mk-num class_+ __add__ __radd__ +-ref err)
-(mk-num class_- __sub__ __rsub__ --ref err)
-(mk-num class_* __mul__ __rmul__ *-ref err)
-(mk-num class_/ __div__ __rdiv__ /-ref err)
-(mk-num class_// __floordiv__ __rfloordiv__ //-ref err)
-(mk-num class_% __divmod__ __rdivmod__ %-ref err)
-(mk-num class_power __pow__ __rpow__ **-ref err)
-(mk-num class_<< __lshift__ __rlshift__ <<-ref err)
-(mk-num class_>> __rshift__ __rrshift__ >>-ref err)
-(mk-log class_ior __or__ __ror__ ior-ref err)
-(mk-log class_xor __xor__ __rxor__ xor-ref err)
-(mk-log class_band __and__ __rand__ and-ref err)
diff --git a/modules/language/python/expr.scm b/modules/language/python/expr.scm
deleted file mode 100644
index 81c2cbe..0000000
--- a/modules/language/python/expr.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-(define-module (language python expr)
- #:use-module (language python class)
- #:export (py-true? to-py py-or py-and py-not py_==
- py_>= py_<= py_< py_> py_<> py_!= py_in py_notin py_is
- py_isnot py_bor py_xor py_band py-<< py->> py-+ py--
- py-* py-/ py-% py-// py-u+ py-u- py-u~ py-power
- ))
-
-
-(define-syntax-rule (py-true? x) (eq? x 'True))
-(define-syntax-rule (to-py x) (if x 'True 'false))
-(define-syntax-rule (py-or x ...) (to-py (or (py-true? x) ...)))
-(define-syntax-rule (py-and x ...) (to-py (and (py-true? x) ...)))
-(define-syntax-rule (py-not x) (if (py-true? x) 'False 'True))
-
-(define-syntax-rule (py_== x y)
- (if (struct? x)
- (if (class? x)
- (class_== x y)
- (to-py (equal? x y)))
- (to-py (equal? x y))))
-
-(define-syntax-rule (mk-comp py_>= >= class_>=)
- (define-syntax-rule (py_>= x y)
- (if (number? x)
- (to-py (>= x y))
- (if (class? x)
- (class_>= x y)
- 'False))))
-
-(mk-comp py_>= >= class_>=)
-(mk-comp py_<= <= class_<=)
-(mk-comp py_< < class_<)
-(mk-comp py_> > class_>)
-
-(define-syntax-rule (<> x y) (not (= x y)))
-(mk-comp py_<> <> class_<>)
-(mk-comp py_!= <> class_<>)
-
-
-(define-syntax-rule (py_in x y)
- (cond
- ((struct? y)
- (if (class? y)
- (to-py (class_in y x))
- 'False))
- ((pair? y)
- (list-in x y))
- ((vector? y)
- (vector-in x y))
- (else
- 'False)))
-
-(define-syntax-rule (py_notin x y)
- (cond
- ((struct? y)
- (if (class? y)
- (to-py (not (class_in y x)))
- 'True))
- ((pair? y)
- (to-py (list-in x y)))
- ((vector? y)
- (to-py (vector-in x y)))
- (else
- 'True)))
-
-(define-syntax-rule (py_is x y)
- (to-py (and (class? x) (class? y) (eq? (class-ref x) (class-ref y)))))
-
-(define-syntax-rule (py_isnot x y)
- (to-py (not (and (class? x) (class? y) (eq? (class-ref x) (class-ref y))))))
-
-(define-syntax-rule (mk-num py_>= >= class_>=)
- (define-syntax-rule (py_>= x . y)
- (if (number? x)
- (>= x . y)
- (if (class? x)
- (class_>= x . y)
- (error "wrong numerics")))))
-
-(mk-num py_bor logior class_ior)
-(mk-num py_xor logxor class_xor)
-(mk-num py_band logand class_band)
-(mk-num py-<< ash class_<<)
-(define-syntax-rule (rash x y) (ash x (- y)))
-(mk-num py->> rash class_>>)
-(mk-num py-+ + class_+)
-(mk-num py-- - class_-)
-(mk-num py-* * class_*)
-(mk-num py-/ / class_/)
-(mk-num py-% modulo class_%)
-(mk-num py-// truncate-quotient class_//)
-
-(define-syntax-rule (mk-unum py_>= >= class_>=)
- (define-syntax-rule (py_>= x)
- (if (number? x)
- (>= x)
- (if (class? x)
- (class_>= x)
- (error "wrong numerics")))))
-
-(mk-unum py-u+ + class_u+)
-(mk-unum py-u- - class_u-)
-(mk-unum py-u~ lognot class_u~)
-
-(mk-num py-power expt class_power)
diff --git a/modules/language/python/python.scm b/modules/language/python/python.scm
deleted file mode 100644
index e8621ad..0000000
--- a/modules/language/python/python.scm
+++ /dev/null
@@ -1,265 +0,0 @@
-(define-module (language python python)
- #:use-module (language python parser)
- #:use-module (language python expr)
- #:use-module (ice-9 match)
- #:export (compile-python-string compile-python-file))
-
-;;; VARIABLES ----------------------------------------------------------------
-(define (find-global-variables vars tree)
- (define (for-each* f l)
- (match l
- ((x . l)
- (f x)
- (for-each* f l))
- (x
- (f x))))
-
- (define (local tree)
- (match tree
- ((#:global l)
- (for-each*
- (lambda (x) (hash-set! vars x #t)) l))
- ((x . l)
- (for-each* local tree))
- (_
- #t)))
-
- (define (collect tree)
- (match tree
- ((#:lambdef . _)
- #t)
- ((#:identifier . l)
- (hash-set! vars tree #t))
- ((_ . _)
- (for-each* collect tree))
- (_
- #t)))
-
- (let lp ((tree tree))
- (match tree
- ((#:def . l)
- (for-each* local l))
- ((#:lambdef . l)
- (for-each* local l))
- ((#:class . l)
- (for-each* local l))
- ((#:expr-stmt
- a (#:assign x ... e))
- (collect a)
- (collect x))
- ((x . l)
- (for-each* lp tree))
- (_
- #t))))
-;; COMPILATION
-
-(define (expr stx out tree)
- (define (expr-lhs tree)
- (match tree
- ((#:test (#:power (#:identifier v . _)))
- (datum->syntax stx (string->symbol v)))))
-
-
- (define (expr-rhs tree)
- (define (comp-tr op)
- (match op
- ("notin" #'py-notin)
- ("isnot" #'py-isnot)
- ("==" #'py_==)
- (">=" #'py_>=)
- ("<=" #'py_<=)
- ("<>" #'py_<>)
- ("!=" #'py_!=)
- ("in" #'py_in)
- ("is" #'py_is)
- ("<" #'py_< )
- (">" #'py_> )))
-
- (let lp ((tree tree))
- (match tree
- ((#:test x #f)
- (lp x))
- ((#:test x (a b))
- #`(if #,(py-true? (lp a)) #,(lp x) #,(lp b)))
- ((#:or x . y)
- #`(py-or #,(lp x) #,@(map lp y)))
- ((#:and x y)
- #`(py-and #,(lp x) #,@(map lp y)))
- ((#:not x)
- #`(py-not #,(lp x)))
- ((#:comp x)
- (lp x))
- ((#:comp x (op . y) . l)
- #'(#,(comp-tr op) #,(lp x) #,(lp (cons* #:comp y l))))
- ((#:bor x y)
- #`(py-bor #,(lp x) #,@(map lp y)))
- ((#:bxor x y)
- #`(py-bxor #,(lp x) #,@(map lp y)))
- ((#:xand x y)
- #`(py-band #,(lp x) #,@(map lp y)))
- ((#:<< x y)
- #`(py-<< #,(lp x) #,@(map lp y)))
- ((#:>> x y)
- #`(py->> #,(lp x) #,@(map lp y)))
- ((#:+ x y)
- #`(py-+ #,(lp x) #,@(map lp y)))
- ((#:- x y)
- #`(py-- #,(lp x) #,@(map lp y)))
- ((#:* x y)
- #`(py-* #,(lp x) #,@(map lp y)))
- ((#:/ x y)
- #`(py-/ #,(lp x) #,@(map lp y)))
- ((#:// x y)
- #`(py-// #,(lp x) #,@(map lp y)))
- ((#:% x y)
- #`(py-% #,(lp x) #,@(map lp y)))
- ((#:u+ x)
- #`(py-u+ #,(lp x)))
- ((#:u- x)
- #`(py-u- #,(lp x)))
- ((#:u~ x)
- #`(py-u~ #,(lp x)))
- ((#:power x trailer . #f)
- (compile-trailer trailer (lp x)))
- ((#:power x trailer . l)
- #'(py-power ,#(compile-trailer trailer (lp x)) #,(lp l)))
- ((#:identifier x . _)
- (datum->syntax stx (string->symbol x)))
- ((not (_ . _))
- tree))))
-
-
-
- (lambda (tree)
- (match tree
- ((test1 (#:assign))
- (expr-rhs test1))
- ((test1 (#:assign tests ... last))
- (with-syntax (((rhs ...) (map expr-rhs last))
- ((lhs1 ...) (map expr-lhs test1))
- (((lhs ...) ...) (reverse (map (lambda (l)
- (map expr-lhs l))
- tests))))
- (with-syntax (((v ...) (generate-temporaries #'(lhs1 ...))))
- (out #'(call-with-values (lambda () (values rhs ...))
- (lambda (v ...)
- (begin
- (set! lhs v) ...)
- ...
- (set! lhs1 v) ...)))))))))
-
-
-(define (compile-outer state out tree)
- (define (compile-stmt state tree)
- (match tree
- ((#:expr-stmt l)
- (compile-expr l))
-
- ((#:del l)
- (compile-del l))
-
- (#:pass
- (out #'(if #f #f)))
-
- (#:break
- (break out))
-
- (#:continue
- (continue out))
-
- ((#:return . l)
- (compile-return state l))
-
- ((#:raise . l)
- (compile-raise state l))
-
- ((#:import l)
- (compile-import state l))
-
- ((#:global . _)
- #t)
-
- ((#:nonlocal . _)
- #t)
-
- ((#:assert . l)
- (compile-assert state l))))
-
- (match tree
- ((#:stmt x)
- (for-each* compile-stmt tree))
- ((#:if . l)
- (compile-if state l))
- ((#:while . l)
- (compile-while state l))
- ((#:for . l)
- (compile-for state l))
- ((#:try . l)
- (compile-try state l))
- ((#:with . l)
- (compile-with state l))
- ((#:def . l)
- (compile-def state l))
- ((#:decorated . l)
- (compile-decorated state l))))
-
-
-(define (compile-python0 stx tree output)
- (define global-variables (make-hash-table))
-
- (find-global-variables global-variables tree)
- (set! all-variables
- (hash-fold
- (lambda (k v e)
- (match k
- ((_ v . _)
- (cons (datum->syntax stx (string->symbol v)) e))))
- '() global-variables))
- (set! all-globals
- (hash-fold
- (lambda (k v e)
- (match k
- ((_ v)
- (cons (datum->syntax stx (string->symbol v)) e))))
- '() global-variables))
-
- (output (with-syntax (((v ...) all-variables))
- #'(begin (define v (if #f #f)) ...)))
-
- (output (with-syntax (((v ...) all-globals))
- #'(export v ...)))
-
- (output #`(begin #,@(compile-outer))))
-
-
-(define (compile-python1 stx tree)
- (let ((out '()))
- (define (out x) (set! out (cons x out)))
- (compile-python0 stx tree out)
- (cons* #'begin (reverse out))))
-
-(define-syntax compile-python-string
- (lambda (x)
- (syntax-case x ()
- ((_ y)
- (if (string? (syntax->datum #'y))
- (compile-python1 x (python-parser (syntax->datum #'y))))))))
-
-(define-syntax compile-python-file
- (lambda (x)
- (syntax-case x ()
- ((_ y)
- (if (string? (syntax->datum #'y))
- (with-input-from-file (syntax->datum #'y)
- (lambda () (compile-python1 x (python-parser))))
- #f)))))
-
-
-
-
-
-
-
-
-
-
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 15:40:59 +0000