From 8e970fdbe01edefb2284544eaa9c4137a350ace8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 6 Jan 2018 17:47:46 -0500 Subject: [PATCH] Implement deferred boot actions and use them for the record.scm actions. --- src/runtime/boot.scm | 34 +++++++++++++++++++- src/runtime/record.scm | 70 +++++++++++++----------------------------- 2 files changed, 55 insertions(+), 49 deletions(-) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index e7fbdf2b8..0b24943a0 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -156,16 +156,48 @@ USA. (for-each (lambda (init) (init)) inits)))))) +(define (defer-boot-action group-name thunk) + (if booting? + (let ((group (%get-boot-action-group group-name))) + (set-cdr! group + (cons thunk + (cdr group)))) + (thunk))) + +(define (run-deferred-boot-actions group-name) + (let ((group (%find-boot-action-group group-name))) + (if group + (begin + (set! boot-action-groups (delq! group boot-action-groups)) + (for-each (lambda (thunk) (thunk)) + (reverse! (cdr group))))))) + +(define (%get-boot-action-group group-name) + (or (%find-boot-action-group group-name) + (let ((group (cons group-name '()))) + (set! boot-action-groups (cons group boot-action-groups)) + group))) + +(define (%find-boot-action-group group-name) + (let loop ((groups boot-action-groups)) + (and (pair? groups) + (if (eq? group-name (caar groups)) + (car groups) + (loop (cdr groups)))))) + (define (finished-booting!) (set! booting? #f) (if (pair? boot-inits) (warn "boot-inits not saved:" boot-inits)) (if (pair? saved-boot-inits) - (warn "saved-boot-inits not run:" saved-boot-inits))) + (warn "saved-boot-inits not run:" saved-boot-inits)) + (if (pair? boot-action-groups) + (warn "boot-action-groups not run:" boot-action-groups))) (define booting? #t) (define boot-inits #f) (define saved-boot-inits '()) +(define boot-action-groups '()) ;;;; Miscellany diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 134dd1b18..3917ee712 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -83,49 +83,23 @@ USA. (define (initialize-record-procedures!) (set! %set-record-type-default-inits! %set-record-type-default-inits!/after-boot) - (process-deferred-generic-inits!) - (process-deferred-property-recordings!)) + (run-deferred-boot-actions 'record/procedures)) (define (defer-generic-init arity name setter default) - (set! deferred-generic-inits - (cons (cons (cons arity name) (cons setter default)) - deferred-generic-inits)) - unspecific) - -(define (process-deferred-generic-inits!) - (for-each (lambda (p) - (let ((g (make-generic-procedure (car (car p)) (cdr (car p))))) - (set-generic-procedure-default-generator! g (cdr (cdr p))) - ((car (cdr p)) g))) - deferred-generic-inits) - (set! deferred-generic-inits) - unspecific) - -(define deferred-generic-inits '()) - -(define (deferred-property-recorder setter handler) - (set! deferred-procedure-settings - (cons (cons setter handler) - deferred-procedure-settings)) + (defer-boot-action 'record/procedures + (lambda () + (let ((g (make-generic-procedure arity name))) + (set-generic-procedure-default-generator! g default) + (setter g))))) + +(define (deferred-property-setter setter handler) + (defer-boot-action 'record/procedures + (lambda () + (setter handler))) (lambda args - (set! deferred-property-recordings - (cons (cons handler args) - deferred-property-recordings)) - unspecific)) - -(define (process-deferred-property-recordings!) - (for-each (lambda (p) - ((car p) (cdr p))) - deferred-procedure-settings) - (set! deferred-procedure-settings) - (for-each (lambda (p) - ((ucode-primitive apply) (car p) (cdr p))) - deferred-property-recordings) - (set! deferred-property-recordings) - unspecific) - -(define deferred-procedure-settings '()) -(define deferred-property-recordings '()) + (defer-boot-action 'record/procedures + (lambda () + ((ucode-primitive apply) handler args))))) (define (make-record-type type-name field-names #!optional @@ -316,7 +290,7 @@ USA. (standard-unparser-method 'record #f)))))) (define set-record-type-unparser-method! - (deferred-property-recorder + (deferred-property-setter (variable-setter set-record-type-unparser-method!) (named-lambda (set-record-type-unparser-method! record-type method) (guarantee-record-type record-type 'set-record-type-unparser-method!) @@ -344,7 +318,7 @@ USA. (standard-unparser-method 'entity #f)))) (define set-record-type-entity-unparser-method! - (deferred-property-recorder + (deferred-property-setter (variable-setter set-record-type-entity-unparser-method!) (named-lambda (set-record-type-entity-unparser-method! record-type method) (guarantee-record-type record-type @@ -382,12 +356,12 @@ USA. (cons (list i (%record-ref record i)) d)))))))) (define set-record-type-describer! - (deferred-property-recorder + (deferred-property-setter (variable-setter set-record-type-describer!) (named-lambda (set-record-type-describer! record-type describer) - (guarantee-record-type record-type 'SET-RECORD-TYPE-DESCRIBER!) + (guarantee-record-type record-type 'set-record-type-describer!) (if describer - (guarantee unary-procedure? describer 'SET-RECORD-TYPE-DESCRIBER!)) + (guarantee unary-procedure? describer 'set-record-type-describer!)) (define-unary-generic-handler record-description record-type describer)))) (define record-entity-describer) @@ -402,13 +376,13 @@ USA. #f)))) (define set-record-type-entity-describer! - (deferred-property-recorder + (deferred-property-setter (variable-setter set-record-type-entity-describer!) (named-lambda (set-record-type-entity-describer! record-type describer) - (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-DESCRIBER!) + (guarantee-record-type record-type 'set-record-type-entity-describer!) (if describer (guarantee unary-procedure? describer - 'SET-RECORD-TYPE-ENTITY-DESCRIBER!)) + 'set-record-type-entity-describer!)) (define-unary-generic-handler record-entity-describer record-type ;; Kludge to make generic dispatch work. (lambda (extra) -- 2.25.1