"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "TeXmacs/progs/part/part-tmfs.scm" between
TeXmacs-1.99.4-src.tar.gz and TeXmacs-1.99.5-src.tar.gz

About: GNU TeXmacs is a what-you-see-is-what-you-get scientific text editor, which was both inspired by TeX and GNU Emacs.

part-tmfs.scm  (TeXmacs-1.99.4-src):part-tmfs.scm  (TeXmacs-1.99.5-src)
skipping to change at line 22 skipping to change at line 22
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(texmacs-module (part part-tmfs) (texmacs-module (part part-tmfs)
(:use (part part-shared) (:use (part part-shared)
(texmacs texmacs tm-files))) (texmacs texmacs tm-files)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Useful subroutines ;; Useful subroutines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tm-suffix? u) (tm-define (part-master name)
(in? (url-suffix u) (list "tm" "tm~" "tm#"))) (with pos (string-search-forwards ".tm/" 0 name)
(if (<= pos 0)
(tm-define (part-master u) (tmfs-string->url name)
(and (url-concat? u) (tmfs-string->url (substring name 0 (+ pos 3))))))
(or (part-master (url-head u))
(and (tm-suffix? u) u)))) (tm-define (part-file name)
(with pos (string-search-forwards ".tm/" 0 name)
(define (part-parent u) (if (<= pos 0)
(and (url-concat? u) (tmfs-string->url name)
(if (tm-suffix? u) (let* ((m (tmfs-string->url (substring name 0 (+ pos 3))))
(url-head u) (s (substring name (+ pos 4) (string-length name)))
(part-parent (url-head u))))) (f (tmfs-string->url s)))
(if (string-starts? s "here/")
(define (part-delta u) (url-relative m f)
(and (url-concat? u) f)))))
(if (tm-suffix? u)
(url-tail u) (tm-define (part-open-name u)
(and-with d (part-delta (url-head u)) (with s (url->string u)
(url-append d (url-tail u)))))) (if (string-starts? s "tmfs://part/")
(string-drop s (string-length "tmfs://part/"))
(tm-define (part-file u) (url->tmfs-string u))))
(let* ((m (part-master u))
(p (part-parent u)) (tm-define (part-url master file)
(d (part-delta u))) (cond ((== master file)
(if (== u m) u (url-relative (part-file p) d)))) (string-append "tmfs://part/" (url->tmfs-string master)))
((url-descends? file (url-head master))
(string-append "tmfs://part/" (url->tmfs-string master)
"/" (url->tmfs-string (url-delta master file))))
(else
(string-append "tmfs://part/" (url->tmfs-string master)
"/" (url->tmfs-string file)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Subroutines for managing the initial environment ;; Subroutines for managing the initial environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (unpack-extra-inits l) (define (unpack-extra-inits l)
(if (or (null? l) (null? (cdr l))) (list) (if (or (null? l) (null? (cdr l))) (list)
(cons `(associate ,(car l) ,(cadr l)) (cons `(associate ,(car l) ,(cadr l))
(unpack-extra-inits (cddr l))))) (unpack-extra-inits (cddr l)))))
(define (get-extra-init t delta) (define (get-extra-init t delta)
(if (and (tm-func? t 'tuple) (cons `(associate "part-flag" "true")
(tm-equal? (tm-ref t 0) delta)) (if (and (tm-func? t 'tuple)
(unpack-extra-inits (cdr (tm-children t))) (tm-equal? (tm-ref t 0) delta))
(list))) (unpack-extra-inits (cdr (tm-children t)))
(list))))
(define (exclude-from-inherit) (define (exclude-from-inherit)
(list "preamble" "mode" (list "preamble" "mode"
"page-medium" "page-printed" "page-first")) "page-medium" "page-printed" "page-first"))
(define (master-inits mas u m) (define (master-inits mas u m)
(let* ((mt (or (tmfile-extract mas 'initial) `(collection))) (let* ((mt (or (tmfile-extract mas 'initial) `(collection)))
(xt (collection-exclude mt (exclude-from-inherit))) (xt (collection-exclude mt (exclude-from-inherit)))
(aux (tmfile-extract mas 'auxiliary)) (aux (tmfile-extract mas 'auxiliary))
(parts (collection-ref aux "parts")) (parts (collection-ref aux "parts"))
skipping to change at line 92 skipping to change at line 99
(tm-atomic? (tm-ref ref 1)) (tm-atomic? (tm-ref ref 1))
(string-number? (tm->string (tm-ref ref 1)))) (string-number? (tm->string (tm-ref ref 1))))
(set! t (collection-set t "page-first" (set! t (collection-set t "page-first"
(tm->string (tm-ref ref 1))))) (tm->string (tm-ref ref 1)))))
t)) t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Titles ;; Titles
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (part-title u)
(cond ((url-concat? u)
(let* ((h (part-title (url-head u)))
(t (part-title (url-tail u))))
(if (and h t) (string-append h " - " t)
(or h t))))
((url-atomic? u)
(and (tm-suffix? u)
(url->string (url-basename u))))
(else #f)))
(tmfs-title-handler (part name doc) (tmfs-title-handler (part name doc)
(if (string-ends? name "/") (set! name (string-append name "x"))) (let* ((m (part-master name))
(with u (tmfs-string->url name) (f (part-file name)))
(or (part-title u) (if (== m f)
(url->system (url-tail u))))) (url->unix (url-basename (url-tail m)))
(string-append (url->unix (url-basename (url-tail m))) " - "
(if (url-rooted-tmfs? f)
(tmfs-title f doc)
(url->unix (url-basename (url-tail f))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Loading ;; Loading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-shared u body) (define (make-shared u body)
(let* ((id (create-unique-id)) (let* ((id (create-unique-id))
(fid (url->unix u))) (fid (url->unix u)))
`(shared ,id ,fid ,(tm->stree body)))) `(shared ,id ,fid ,(tm->stree body))))
skipping to change at line 155 skipping to change at line 155
((tm-is? doc 'document) ((tm-is? doc 'document)
(when (and (tmfile-extract doc 'body) (when (and (tmfile-extract doc 'body)
(not (tmfile-extract doc 'initial))) (not (tmfile-extract doc 'initial)))
(set! doc (tmfile-assign doc 'initial (assoc->collection (list))))) (set! doc (tmfile-assign doc 'initial (assoc->collection (list)))))
(cons 'document (cons 'document
(map (cut part-expand <> mas u m) (map (cut part-expand <> mas u m)
(tm-children doc)))) (tm-children doc))))
(else doc))) (else doc)))
(tmfs-load-handler (part name) (tmfs-load-handler (part name)
(if (string-ends? name "/") (set! name (string-append name "x"))) (let* ((m (part-master name))
(let* ((u (tmfs-string->url name)) (f (part-file name))
(m (part-master u))
(f (part-file u))
(doc (tree-import f "texmacs")) (doc (tree-import f "texmacs"))
(mas (if (== m f) doc (tree-import m "texmacs"))) (mas (if (== m f) doc (tree-import m "texmacs")))
(exp (part-expand doc mas f m))) (exp (part-expand doc mas f m)))
(if (and m f (not (string-ends? name "/x"))) (tmfs-document exp)))
(tmfs-document exp)
($generic "Invalid file."))))
(tmfs-master-handler (part name) (tmfs-master-handler (part name)
(if (string-ends? name "/") (set! name (string-append name "x"))) (part-file name))
(let* ((u (tmfs-string->url name))
(f (part-file u)))
(or f name)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Saving ;; Saving
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (part-compress-body doc u) (define (part-compress-body doc u)
(cond ((tm-func? doc 'document) (cond ((tm-func? doc 'document)
(cons (tm-label doc) (cons (tm-label doc)
(map (cut part-compress-body <> u) (tm-children doc)))) (map (cut part-compress-body <> u) (tm-children doc))))
((tm-func? doc 'shared 3) ((tm-func? doc 'shared 3)
skipping to change at line 213 skipping to change at line 206
(ft (tm-ref doc 0)) (ft (tm-ref doc 0))
(t (collection-delta mt ft))) (t (collection-delta mt ft)))
`(initial ,t))) `(initial ,t)))
((tm-is? doc 'document) ((tm-is? doc 'document)
(cons 'document (cons 'document
(map (cut part-compress <> ori mas u m) (map (cut part-compress <> ori mas u m)
(tm-children doc)))) (tm-children doc))))
(else doc))) (else doc)))
(tmfs-save-handler (part name doc) (tmfs-save-handler (part name doc)
(if (string-ends? name "/") (set! name (string-append name "x"))) (let* ((m (part-master name))
(let* ((u (tmfs-string->url name)) (f (part-file name))
(m (part-master u))
(f (part-file u))
(ori (tree-import f "texmacs")) (ori (tree-import f "texmacs"))
(mas (if (== m f) doc (tree-import m "texmacs"))) (mas (if (== m f) doc (tree-import m "texmacs")))
(com (part-compress doc ori mas f m))) (com (part-compress doc ori mas f m)))
;;(display* "com= " (tm->stree com) "\n") ;;(display* "com= " (tm->stree com) "\n")
(if (tree-export (tm->tree com) f "texmacs") (if (tree-export (tm->tree com) f "texmacs")
(buffer-pretend-modified f) (buffer-pretend-modified f)
(buffer-pretend-saved f)))) (buffer-pretend-saved f))))
(tmfs-autosave-handler (part name suf) (tmfs-wrap-handler (part name)
(if (string-ends? name "/") (set! name (string-append name "x"))) (part-file name))
(let* ((u (tmfs-string->url name))
(f (part-file u)))
(and (url-autosave f suf)
(string-append "tmfs://part/" name suf))))
(tmfs-remove-handler (part name)
(if (string-ends? name "/") (set! name (string-append name "x")))
(let* ((u (tmfs-string->url name))
(f (part-file u)))
(url-remove f)))
(tmfs-date-handler (part name)
(if (string-ends? name "/") (set! name (string-append name "x")))
(let* ((u (tmfs-string->url name))
(f (part-file u)))
(url-last-modified f)))
(tmfs-permission-handler (part name type)
(if (string-ends? name "/") (set! name (string-append name "x")))
(let* ((u (tmfs-string->url name))
(f (part-file u)))
(cond ((not f) #f)
((== type "read") (url-test? f "r"))
((== type "write") (url-test? f "w"))
(else #f))))
 End of changes. 9 change blocks. 
60 lines changed or deleted 51 lines changed or added

Home  |  About  |  All  |  Newest  |  Fossies Dox  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTPS