Further improvements

parent efbb9d4f
......@@ -395,9 +395,16 @@ add/run * vlist *
(vector t tree ar (remove l rems)))))))
(define (rm s f one?)
(let ((e (fluid-ref env)))
(fluid-set! env (cons (rm-raw s f (car e) one?)
(rm-raw s f (cdr e) one?)))))
(let* ((e (fluid-ref env))
(rm? #f)
(a1 (rm-raw s (lambda x
(if (apply f x)
(begin (set! rm? one?) #t)
#f))
(car e) one?))
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one?))))
(fluid-set! env (cons a1 a2))))
(define (compile-raw e)
(let* ((l (get-dyn e))
......
......@@ -61,7 +61,7 @@
;; symbols
not_less_than_zero evaluable callable modify
static_procedure access end_of_file
predicate_indicator
predicate_indicator private_procedure
;; characters
atom_length atom_concat atom_chars atom_codes char_code
......
......@@ -105,15 +105,20 @@
(((('fx _ ":-" _) z . _))
(list #f #f z))
((#:translated (#:untranslate x))
(top x))
((#:translated _)
x)
((#:atom v _ _)
(list v '() '()))
((#:atom v n m)
(if (is-dynamic? v)
`(#:translated ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
,x ,n ,m))))
(list v '() '())))
((#:term (#:atom v . _) y n m)
(if (is-dynamic? v)
......@@ -126,7 +131,8 @@
(pp 'compile l)
(clear-syms)
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse l)))) less)))
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse l))))
less)))
(in.r (let lp ((l-r l-r) (r '()))
(match (pp 'ini l-r)
(((#:translated x) . l)
......@@ -142,7 +148,7 @@
(lp f x l (list (cons x y))
(cons (reverse r) rl) res)))
(match l
(match (pp 'com l)
(((v x y) . l)
(if f
(if (eq? v f)
......
......@@ -74,7 +74,7 @@
(cond
((and (string? x) (ch1? x))
(string-ref x 1))
(string-ref x 0))
((procedure? x)
(->ch (procedure-name x)))
((symbol? x)
......
......@@ -92,6 +92,10 @@
(c2 (chars-> c1)))
(<=> (a b c) (a2 b2 c2))))))))))
(define unary-minus (@@ (logic guile-log prolog
goal-transformers)
unary-minus))
(<define> (check-achars l L)
(<let> ((l (<lookup> l)))
(if (<var?> l)
......@@ -104,6 +108,7 @@
((<var?> x)
(instantiation_error))
((not (or (char? x)
(and (procedure? x) (eq? x unary-minus))
(and (string? x)
(= (string-length x) 1))
(and (procedure? x)
......@@ -147,11 +152,13 @@
(cons (string-ref x 0) (plist->chars (cdr l))))
((number? x)
(cons (integer->char x) (plist->chars (cdr l))))
((procedure? x)
(cons (string-ref (symbol->string (procedure-name x)) 0)
(plist->chars (cdr l))))
((procedure? x)
(cons (if (eq? x unary-minus)
#\-
(string-ref (symbol->string (procedure-name x)) 0))
(plist->chars (cdr l))))
(else
(cons x (plist->chars (cdr l)))))))
(cons x (plist->chars (cdr l)))))))
(else
l)))
......
......@@ -42,7 +42,7 @@
initialization local_initialization
clear-directives is-dynamic?
))
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
......
......@@ -83,15 +83,21 @@
(else
(<var> (F A)
(<if> (<=> Head ,(vector (cons F A)))
(<if> (<or> (<=> Head ,(vector (cons F A)))
(<and> (<=> Head F) (<=> A ())))
(<let> ((FF (<lookup> F)))
(if (dynamic? FF)
(<clause-dynamic> (<lookup> F) A Body)
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A)))))))
(cond
((dynamic? FF)
(<clause-dynamic> FF A Body))
((procedure? FF)
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A))))))
(else
(type_error callable F))))
(type_error callable Head)))))))
(<define> (retract Arg)
......@@ -123,9 +129,8 @@
(<let> ((F (<lookup> F)))
(if (dynamic? F)
(<and>
(<clause-dynamic> (<lookup> F) A true)
(<retract-dynamic> (<lookup> F)
(cons A true)))
(<clause-dynamic> F A true)
(<retract-dynamic> F (cons A true)))
(permission_error
modify static_procedure
(vector (list divide
......@@ -162,7 +167,7 @@
(type_error atom F)))))
(_
(type_error divide pred)))))))
(type_error predicate_indicator pred)))))))
(define (get-dyns mod)
......
......@@ -178,6 +178,8 @@
(cons s #f)))
(lambda x (cons #t #t))))
(define *open-ports* (make-fluid '()))
(define open
(<case-lambda>
((SS Mode Stream)
......@@ -267,6 +269,8 @@
`((#:repos . #f)
(#:eof . ,e)
(#:mode . ,Mode)))
(fluid-set! *open-ports*
(cons s (fluid-ref *open-ports*)))
(if a
(set-procedure-property!
a 'prolog-alias s)))
......@@ -280,16 +284,34 @@
(props (object-property s 'prolog-meta)))
(cond
((<var?> s)
(instantiation_error))
(<recur> lp ((l (fluid-ref *open-ports*)))
(if (pair? l)
(<or> (stream_property (car l) prop)
(lp (cdr l))))))
((not (prolog-stream? s))
((not (prolog-stream-alias? s))
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
(domain_error stream ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((<var?> prop)
(<var> (P)
(<or>
(<=> prop ,(vector (list file_name P)))
(<=> prop ,(vector (list mode P)))
(<=> prop ,(vector (list type P)))
(<=> prop ,input)
(<=> prop ,output)
(<=> prop ,(vector (list alias P)))
(<=> prop ,(vector (list position P)))
(<=> prop ,(vector (list end_of_stream P)))
(<=> prop ,(vector (list eof_action P))))
(stream_property s prop)))
(else
(<match> (#:mode - #:name stream_property) (prop)
(#((,file_name f))
......@@ -350,7 +372,8 @@
(cdr (assq #:eof props))
(cdr (assq #:eof-action default-open-option))))))
(_ (<cut> <fail>)))))))
(_
(domain_error stream_property prop)))))))
(define (stream-option? opt)
(match opt
......@@ -398,6 +421,15 @@
(if (not (or (eq? s (fluid-ref *standard-input*))
(eq? s (fluid-ref *standard-output*))))
(begin
(fluid-set! *open-ports* (let lp ((l (fluid-ref *open-ports*))
(r '()))
(if (pair? l)
(if (eq? s (car l))
((@@ (guile) append)
(reverse r)
(cdr l))
(lp (cdr l)
(cons (car l) r))))))
(close-port s))))))))))
......@@ -604,7 +636,7 @@
(permission_error output stream ss))
((binary-port? s)
(permission_error input binary stream ss))
(permission_error input binary_stream ss))
(else
(<var> (chch)
......@@ -756,12 +788,15 @@
(instantiation_error))
((and (not (<var?> ch)) (not (prolog-char? ch)))
(type_error character ch))
((not (prolog-stream-alias? s))
(existence_error stream ss))
((prolog-stream-closed? s)
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((not (prolog-input-stream? s))
(permission_error input stream ss))
#;((binary-port? s)
......@@ -786,11 +821,11 @@
((and (not (<var?> code)) (not (and (number? code) (integer? code))))
(type_error integer code))
((not (prolog-stream-alias? s))
(existence_error stream ss))
((prolog-stream-closed? s)
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((not (prolog-input-stream? s))
(permission_error input stream ss))
((binary-port? s)
......@@ -813,14 +848,18 @@
(cond
((<var?> s)
(instantiation_error))
((and (not (<var?> code)) (not (and (number? code) (integer? code))))
(type_error integer code))
((not (prolog-stream-alias? s))
(existence_error stream ss))
((prolog-stream-closed? s)
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((not (prolog-input-stream? s))
(permission_error input stream ss))
#;((not (binary-port? s))
......
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