From 427fe943328dc964bfe75448e86abe15682accda Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Wed, 4 Apr 2018 19:08:28 +0200 Subject: improving python parser and compiler --- modules/language/python/compile.scm | 126 +++++++++++++++++--------- modules/language/python/dict.scm | 2 +- modules/oop/pf-objects.scm | 171 +++++++++++++++++++----------------- 3 files changed, 177 insertions(+), 122 deletions(-) (limited to 'modules') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index f936aa0..8f5139d 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -17,6 +17,7 @@ #:use-module (language python module) #:use-module (language python dir) #:use-module (language python procedure) + #:use-module (language python bool) #:use-module ((language python with) #:select ()) #:use-module (ice-9 pretty-print) #:export (comp)) @@ -415,15 +416,54 @@ (() (values (reverse l) (reverse kw)))))) -(define (get-kwarg-def vs arg) +(define (get-args_ vs arg) (let lp ((arg arg)) (match arg - ((((x . _) #f) . arg) - (cons (exp vs x) + (((#:arg x) . arg) + (cons (exp vs (car x)) (lp arg))) - ((((a . _) b) . arg) - (cons (list '= (exp vs a) (exp vs b)) + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args= vs arg) + (let lp ((arg arg)) + (match arg + (((#:= x v) . arg) + (cons (list '= (exp vs (car x)) (exp vs v)) + (lp arg))) + + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args* vs arg) + (let lp ((arg arg)) + (match arg + (((#:* x) . arg) + (cons (exp vs (car x)) + (lp arg))) + + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args** vs arg) + (let lp ((arg arg)) + (match arg + (((#:** x) . arg) + (cons (exp vs (car x)) (lp arg))) + + ((x . args) + (lp args)) + (() '())))) @@ -757,22 +797,25 @@ (#:not ((_ x) - (list 'not (exp vs x)))) + (list 'not (list (C 'boolit) (exp vs x))))) (#:or ((_ . x) - (cons 'or (map (g vs exp) x)))) + (cons 'or (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) (#:and ((_ . x) - (cons 'and (map (g vs exp) x)))) + (cons 'and (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) (#:test ((_ e1 #f) (exp vs e1)) - - ((_ e1 e2 e3) - (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))) + + ((_ e1 (e2 #f)) + (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None))) + + ((_ e1 (e2 e3)) + (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3)))) (#:del ;;We don't delete variables @@ -797,9 +840,10 @@ (#:if ((_ test a ((tests . as) ...) . else) `(,(G 'cond) - (,(exp vs test) ,(exp vs a)) - ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as) - ,@(if else `((else ,(exp vs else))) '())))) + (,(list (C 'boolit) (exp vs test)) ,(exp vs a)) + ,@(map (lambda (p a) (list (list (C 'boolit) (exp vs p)) + (exp vs a))) tests as) + ,@(if else `((else ,(exp vs else))) '())))) (#:suite ((_ . l) (cons 'begin (map (g vs exp) l)))) @@ -984,6 +1028,9 @@ (match exc ((((test . #f) code) . exc) (lp exc (cons `(#:except ,(exp vs code)) r))) + + (((#f code) . exc) + (lp exc (cons `(#:except ,(exp vs code)) r))) ((((test . as) code) . exc) (let ((l (gensym "l"))) @@ -1038,37 +1085,25 @@ (#:def ((_ f - (#:types-args-list - args - *e **e) + (#:types-args-list . args) #f code) (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) - (args (get-kwarg-def vs args)) + (args (get-args_ vs args)) + (arg= (get-args= vs args)) + (dd= (map cadr arg=)) (c? (fluid-ref is-class?)) (f (exp vs f)) (y? (is-yield f #f code)) (r (gensym "return")) - (*f (match *e - (((e . #f) ()) (list (list '* (exp vs e)))) - (#f '()))) - (dd2 (match *e - (((e . #f) ()) (list (exp vs e))) - (#f '()))) - (**f (match **e - ((e . #f) (list (list '** (exp vs e)))) - (#f '()))) - (dd3 (match **e - ((e . #f) (list (exp vs e))) - (#f '()))) - (as (map (lambda (x) (match x - (('= a _) a) - (a a))) - args)) + (*f (get-args* vs args)) + (dd* (map cadr *f)) + (**f (get-args** vs args)) + (dd** (map cadr **f)) (ab (gensym "ab")) - (vs (union dd3 (union dd2 (union as vs)))) + (vs (union dd** (union dd* (union dd= (union args vs))))) (ns (scope code vs)) (df (defs code '())) (ex (gensym "ex")) @@ -1091,7 +1126,7 @@ `(define ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1100,7 +1135,7 @@ `(define ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1111,7 +1146,7 @@ `(define ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1120,7 +1155,7 @@ (exp ns code)))))))))) `(define ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1300,7 +1335,9 @@ ((e) (exp vs e)) ((tag . l) - ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs)) + ((hash-ref tagis tag + (lambda y (warn (format #f "not tag in tagis ~a" tag)) x)) + x vs)) (#:True #t) (#:None (E 'None)) @@ -1878,3 +1915,12 @@ ((_ s c) (syntax-parameterize ((*class* (lambda (x) #'s))) c)))) + +(define-syntax boolit + (syntax-rules (and or not) + ((_ (and x y)) (and (boolit x) (boolit y))) + ((_ (or x y)) (or (boolit x) (boolit y))) + ((_ (not x )) (not (boolit x))) + ((_ #t) #t) + ((_ #f) #f) + ((_ x ) (bool x)))) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index c034503..260aa0d 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -485,7 +485,7 @@ (define-method (write (o ) . l) (define port (match l (() #f) ((p) p))) - (define li (hash-fold cons* '() (slot-ref o 't))) + (define li (hash-fold cons* '() (slot-ref o 't))) (if (null? li) (format port "{}") (format port "{~a: ~a~{, ~a: ~a~}}" (car li) (cadr li) (cddr li)))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 792a89a..8ac2325 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -700,88 +700,93 @@ explicitly tell it to not update etc. (define type #f) (define object #f) -(define (make-p-class name supers.kw methods) - (define kw (cdr supers.kw)) - (define supers (car supers.kw)) - (define goopses (map (lambda (sups) - (aif it (ref sups '__goops__ #f) - it - sups)) - supers)) - (define parents (let ((p (filter-parents supers))) - (if (null? p) - (if object - (list object) - '()) - p))) - - (define meta (aif it (memq #:metaclass kw) - (cadr it) - (if (null? parents) - type - (let* ((p (car parents)) - (m (ref p '__class__)) - (mro (reverse (ref m '__mro__ '())))) - (let lp ((l (cdr parents)) - (max mro) - (min mro)) - (if (pair? l) - (let* ((p (car l)) - (meta (ref p '__class__)) - (mro (ref meta '__mro__ '()))) - (let lp2 ((max max) (mr (reverse mro))) - (if (and (pair? max) (pair? mr)) - (if (eq? (car max) (car mr)) - (lp2 (cdr max) (cdr mr)) - (error - "need a common lead for meta")) - (if (pair? max) - (if (< (length mro) (length min)) - (lp (cdr l) max mro) - (lp (cdr l) max min)) - (lp (cdr l) mro min))))) - (car (reverse min)))))))) +(define make-p-class + (case-lambda + ((name supers.kw methods) + (make-p-class name "" supers.kw methods)) + ((name doc supers.kw methods) + (define kw (cdr supers.kw)) + (define supers (car supers.kw)) + (define goopses (map (lambda (sups) + (aif it (ref sups '__goops__ #f) + it + sups)) + supers)) + (define parents (let ((p (filter-parents supers))) + (if (null? p) + (if object + (list object) + '()) + p))) + + (define meta (aif it (memq #:metaclass kw) + (cadr it) + (if (null? parents) + type + (let* ((p (car parents)) + (m (ref p '__class__)) + (mro (reverse (ref m '__mro__ '())))) + (let lp ((l (cdr parents)) + (max mro) + (min mro)) + (if (pair? l) + (let* ((p (car l)) + (meta (ref p '__class__)) + (mro (ref meta '__mro__ '()))) + (let lp2 ((max max) (mr (reverse mro))) + (if (and (pair? max) (pair? mr)) + (if (eq? (car max) (car mr)) + (lp2 (cdr max) (cdr mr)) + (error + "need a common lead for meta")) + (if (pair? max) + (if (< (length mro) (length min)) + (lp (cdr l) max mro) + (lp (cdr l) max min)) + (lp (cdr l) mro min))))) + (car (reverse min)))))))) - (define goops (make-class (append goopses (list (kw->class kw meta))) - '() #:name name)) - - (define (make-module) - (let ((l (module-name (current-module)))) - (if (and (>= (length l) 3) - (equal? (list-ref l 0) 'language) - (equal? (list-ref l 1) 'python) - (equal? (list-ref l 2) 'module)) - (string-join - (map symbol->string (cdddr l)) - ".") - l))) + (define goops (make-class (append goopses (list (kw->class kw meta))) + '() #:name name)) + + (define (make-module) + (let ((l (module-name (current-module)))) + (if (and (>= (length l) 3) + (equal? (list-ref l 0) 'language) + (equal? (list-ref l 1) 'python) + (equal? (list-ref l 2) 'module)) + (string-join + (map symbol->string (cdddr l)) + ".") + l))) - (define (gen-methods dict) - (methods dict) - (pylist-set! dict '__goops__ goops) - (pylist-set! dict '__class__ meta) - (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table)) - (pylist-set! dict '__module__ (make-module)) - (pylist-set! dict '__bases__ parents) - (pylist-set! dict '__fget__ #t) - (pylist-set! dict '__fset__ #t) - (pylist-set! dict '__name__ name) - (pylist-set! dict '__qualname__ name) - (pylist-set! dict '__class__ meta) - (pylist-set! dict '__mro__ (get-mro parents)) - dict) - - (let ((cl (with-fluids ((*make-class* #t)) - (create-class meta name parents gen-methods kw)))) - (aif it (ref meta '__init_subclass__) - (let lp ((ps parents)) - (if (pair? ps) - (let ((super (car ps))) - (it cl super) - (lp (cdr ps))))) - #f) + (define (gen-methods dict) + (methods dict) + (pylist-set! dict '__goops__ goops) + (pylist-set! dict '__class__ meta) + (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table)) + (pylist-set! dict '__module__ (make-module)) + (pylist-set! dict '__bases__ parents) + (pylist-set! dict '__fget__ #t) + (pylist-set! dict '__fset__ #t) + (pylist-set! dict '__name__ name) + (pylist-set! dict '__qualname__ name) + (pylist-set! dict '__class__ meta) + (pylist-set! dict '__mro__ (get-mro parents)) + (pylist-set! dict '__doc__ doc) + dict) + + (let ((cl (with-fluids ((*make-class* #t)) + (create-class meta name parents gen-methods kw)))) + (aif it (ref meta '__init_subclass__) + (let lp ((ps parents)) + (if (pair? ps) + (let ((super (car ps))) + (it cl super) + (lp (cdr ps))))) + #f) - cl)) + cl)))) @@ -807,6 +812,8 @@ explicitly tell it to not update etc. (lambda (x) (syntax-case x () ((_ name parents (ddef dname dval) ...) + #'(mk-p-class name parents "" (ddef dname dval) ...)) + ((_ name parents doc (ddef dname dval) ...) (with-syntax (((ddname ...) (map (lambda (dn) (datum->syntax @@ -832,7 +839,7 @@ explicitly tell it to not update etc. #'(let () (define name (letruc ((dname (make-up dval)) ...) - (make-p-class 'name + (make-p-class 'name doc parents (lambda (dict) (pylist-set! dict 'dname dname) @@ -853,10 +860,12 @@ explicitly tell it to not update etc. (lambda (x) (syntax-case x () ((_ name parents (ddef dname dval) ...) + #'(mk-p-class-noname name parents "" (ddef dname dval) ...)) + ((_ name parents doc (ddef dname dval) ...) #'(let () (define name (letruc ((dname dval) ...) - (make-p-class 'name + (make-p-class 'name doc parents (lambda (dict) (pylist-set! dict 'dname dname) -- cgit v1.2.3