gexp: Keep only a single 'references' field.

The distinction between native inputs and "normal" inputs can already be
determined by looking at the 'native?' field of <gexp-input>.  The extra
'natives' field of <gexp> added complexity for no good reason.

* guix/gexp.scm (<gexp>)[natives]: Remove.
(write-gexp): Remove use of 'gexp-native-references'.
(gexp-inputs)[native-input?]: New procedure.
Use it.
(gexp->sexp)[reference->sexp]: Honor N? for input lists.
Remove use of 'gexp-native-references'.
(gexp)[collect-native-escapes]: Remove.
Simplify.
This commit is contained in:
Ludovic Courtès 2016-07-02 23:19:40 +02:00
parent 08858812b5
commit affd7761f3
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 15 additions and 42 deletions

View File

@ -98,11 +98,10 @@
;; "G expressions". ;; "G expressions".
(define-record-type <gexp> (define-record-type <gexp>
(make-gexp references natives proc) (make-gexp references proc)
gexp? gexp?
(references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) (references gexp-references) ;list of <gexp-input>
(natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) (proc gexp-proc)) ;procedure
(proc gexp-proc)) ; procedure
(define (write-gexp gexp port) (define (write-gexp gexp port)
"Write GEXP on PORT." "Write GEXP on PORT."
@ -113,8 +112,7 @@
;; tries to use 'append' on that, which fails with wrong-type-arg. ;; tries to use 'append' on that, which fails with wrong-type-arg.
(false-if-exception (false-if-exception
(write (apply (gexp-proc gexp) (write (apply (gexp-proc gexp)
(append (gexp-references gexp) (gexp-references gexp))
(gexp-native-references gexp)))
port)) port))
(format port " ~a>" (format port " ~a>"
(number->string (object-address gexp) 16))) (number->string (object-address gexp) 16)))
@ -630,11 +628,15 @@ references; otherwise, return only non-native references."
;; Ignore references to other kinds of objects. ;; Ignore references to other kinds of objects.
result))) result)))
(define (native-input? x)
(and (gexp-input? x)
(gexp-input-native? x)))
(fold-right add-reference-inputs (fold-right add-reference-inputs
'() '()
(if native? (if native?
(gexp-native-references exp) (filter native-input? (gexp-references exp))
(gexp-references exp)))) (remove native-input? (gexp-references exp)))))
(define gexp-native-inputs (define gexp-native-inputs
(cut gexp-inputs <> #:native? #t)) (cut gexp-inputs <> #:native? #t))
@ -687,7 +689,7 @@ and in the current monad setting (system type, etc.)"
(if (gexp-input? ref) (if (gexp-input? ref)
ref ref
(%gexp-input ref "out" n?)) (%gexp-input ref "out" n?))
native?)) (or n? native?)))
refs))) refs)))
(($ <gexp-input> (? struct? thing) output n?) (($ <gexp-input> (? struct? thing) output n?)
(let ((target (if (or n? native?) #f target))) (let ((target (if (or n? native?) #f target)))
@ -706,9 +708,7 @@ and in the current monad setting (system type, etc.)"
(mlet %store-monad (mlet %store-monad
((args (sequence %store-monad ((args (sequence %store-monad
(append (map reference->sexp (gexp-references exp)) (map reference->sexp (gexp-references exp)))))
(map (cut reference->sexp <> #t)
(gexp-native-references exp))))))
(return (apply (gexp-proc exp) args)))) (return (apply (gexp-proc exp) args))))
(define (syntax-location-string s) (define (syntax-location-string s)
@ -741,33 +741,9 @@ and in the current monad setting (system type, etc.)"
((ungexp-splicing _ ...) ((ungexp-splicing _ ...)
(cons exp result)) (cons exp result))
((ungexp-native _ ...) ((ungexp-native _ ...)
result)
((ungexp-native-splicing _ ...)
result)
((exp0 exp ...)
(let ((result (loop #'exp0 result)))
(fold loop result #'(exp ...))))
(_
result))))
(define (collect-native-escapes exp)
;; Return all the 'ungexp-native' forms present in EXP.
(let loop ((exp exp)
(result '()))
(syntax-case exp (ungexp
ungexp-splicing
ungexp-native
ungexp-native-splicing)
((ungexp-native _)
(cons exp result))
((ungexp-native _ _)
(cons exp result)) (cons exp result))
((ungexp-native-splicing _ ...) ((ungexp-native-splicing _ ...)
(cons exp result)) (cons exp result))
((ungexp _ ...)
result)
((ungexp-splicing _ ...)
result)
((exp0 exp ...) ((exp0 exp ...)
(let ((result (loop #'exp0 result))) (let ((result (loop #'exp0 result)))
(fold loop result #'(exp ...)))) (fold loop result #'(exp ...))))
@ -838,14 +814,11 @@ and in the current monad setting (system type, etc.)"
(syntax-case s (ungexp output) (syntax-case s (ungexp output)
((_ exp) ((_ exp)
(let* ((normals (delete-duplicates (collect-escapes #'exp))) (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
(natives (delete-duplicates (collect-native-escapes #'exp)))
(escapes (append normals natives))
(formals (generate-temporaries escapes)) (formals (generate-temporaries escapes))
(sexp (substitute-references #'exp (zip escapes formals))) (sexp (substitute-references #'exp (zip escapes formals)))
(refs (map escape->ref normals)) (refs (map escape->ref escapes)))
(nrefs (map escape->ref natives))) #`(make-gexp (list #,@refs)
#`(make-gexp (list #,@refs) (list #,@nrefs)
(lambda #,formals (lambda #,formals
#,sexp))))))) #,sexp)))))))