Changeset 1186 in project


Ignore:
Timestamp:
07/04/06 21:13:29 (14 years ago)
Author:
felix winkelmann
Message:

mailbox got own queue implementation

Files:
47 edited

Legend:

Unmodified
Added
Removed
  • chicken/CMakeLists.txt

    r1063 r1186  
    819819  easyffi
    820820  optimizer
    821   partition
    822821  support
    823822)
     
    926925LIBRARY_SCM_TO_C(match)
    927926SIMPLE_SCM_TO_C(optimizer parameters tweaks)
    928 SIMPLE_SCM_TO_C(partition)
    929927LIBRARY_SCM_TO_C_EXPORTS(pcre regex-common)
    930928UNSAFE_LIBRARY_SCM_TO_C(pcre regex-common)
  • chicken/Makefile.am

    r1016 r1186  
    5252
    5353chicken_SOURCES =
    54 chicken_LDADD = chicken.lo support.lo partition.lo easyffi.lo compiler.lo optimizer.lo c-platform.lo c-backend.lo batch-driver.lo libchicken.la $(MORE_LIBS)
     54chicken_LDADD = chicken.lo support.lo easyffi.lo compiler.lo optimizer.lo c-platform.lo c-backend.lo batch-driver.lo libchicken.la $(MORE_LIBS)
    5555chicken_LDFLAGS = $(LINKFLAGS)
    5656
    5757chicken_static_SOURCES =
    58 chicken_static_LDADD = chicken.o support.o partition.o easyffi.o compiler.o optimizer.o c-platform.o c-backend.o batch-driver.o libchicken.la $(MORE_STATIC_LIBS)
     58chicken_static_LDADD = chicken.o support.o easyffi.o compiler.o optimizer.o c-platform.o c-backend.o batch-driver.o libchicken.la $(MORE_STATIC_LIBS)
    5959chicken_static_LDFLAGS = -static $(LINKFLAGS)
    6060
     
    8080c-backend.c : tweaks.scm
    8181support.c : parameters.scm tweaks.scm banner.scm
    82 partition.c : partition.scm
    8382batch-driver.c : parameters.scm parameters.scm
    8483c-platform.c : tweaks.scm
     
    473472        rm -f $(bindir)/csc
    474473        rm -f $(bindir)/csi
     474        rm -f $(bindir)/csi-static
     475        rm -f $(infodir)/chicken.info
    475476        rm -f $(mandir)/man1/chicken.1
    476477        rm -f $(mandir)/man1/chicken-profile.1
     
    478479        rm -f $(mandir)/man1/csc.1
    479480        rm -f $(mandir)/man1/csi.1
     481        rm -f $(libdir)/libchicken.*
     482        rm -f $(libdir)/libuchicken.*
    480483        rm -fr $(pkglibdir)
    481484        rm -fr $(pkgdatadir)
  • chicken/NEWS

    r1016 r1186  
    77    helpful in finding unbound variable errors (this requires all extensions ("eggs") to be
    88    adapted to this new feature, a process which isn't complete yet)
    9   * new declaration `emit-exports'
     9  * new declarations `emit-exports', `constant' and `import'
    1010  * new option `-disable-warning' and declaration `disable-warning'
    11   * new option `-release'
     11  * new options `-release' and `-import'
    1212- chicken-setup:
    1313  * new `exports' extension property
     
    1616  * added parameters `setup-install-flag' and `setup-verbose-flag'
    1717- FFI:
    18   * added the handy `$' macro, which lets you do foreign calls directly
     18  * added the handy `$' macro, which lets you do foreign calls directly without declaring
     19    a placeholder procedure
    1920  * `define-foreign-enum' for treating C enums as symbol-sets
    2021  * `foreign-safe-wrapper' has been deprecated
     
    4142  of CHICKEN or install on a shared network
    4243- csc: added `-dry-run' option
     44- removed `-split...' options (and the ability to generate multiple C files from a single
     45  Scheme file)
    4346
    4447Many thanks to Nico Amtsberg, Arto Bendiken, Jean-Francois Bignolles, Peter Busser, Thomas Chust,
  • chicken/README

    r1063 r1186  
    33  (c)2000-2003 Felix L. Winkelmann
    44
    5   Version 2, Build 321
     5  Version 2, Build 324
    66
    77
     
    234234          Currently this feature has only been tested on x86 Linux.
    235235          (Note: a more recent development snapshot of libffi is available at
    236           http://www.call-with-current-continuation.org/libffi-2.tgz).
     236          http://www.call-with-current-continuation.org/libffi-3.tgz).
    237237          If you experience any problems with your libfi installation, you can disable support for it
    238238          by passing "--without-libffi" to configure.
  • chicken/batch-driver.scm

    r1016 r1186  
    5252  target-heap-size target-stack-size target-heap-growth target-heap-shrinkage
    5353  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    54   target-initial-heap-size split-level postponed-initforms
     54  target-initial-heap-size postponed-initforms
    5555  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    5656  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
     
    7373  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    7474  default-profiling-declarations default-optimization-passes compressed-literals-initializer
    75   inline-max-size file-requirements use-import-table
     75  inline-max-size file-requirements use-import-table lookup-exports-file
    7676  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
    7777  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    114114                       [(memq 'to-stdout options) #f]
    115115                       [else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
    116         [partitions (cond [(memq 'split options)
    117                            => (lambda (node)
    118                                 (let ([oname (option-arg node)])
    119                                   (cond
    120                                     ((symbol? oname)
    121                                      (string->number (symbol->string oname)))
    122                                     ((string? oname)
    123                                      (string->number oname))
    124                                     (else oname))))]
    125                           [else 1])]
    126116        [ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))]
    127117        [opasses default-optimization-passes]
     
    144134        [ffi-mode (memq 'ffi options)]
    145135        [ffi-parse-mode (memq 'ffi-parse options)]
    146         [ofilelist #f]
    147136        [quiet (memq 'quiet options)]
    148137        [ssize (or (memq 'nursery options) (memq 'stack-size options))] )
    149 
    150     (define (outfile->list outfile num)
    151       (cond
    152        [(not outfile) #f]
    153        [(= num 1) (list outfile)]
    154        [else
    155         (let ([file (pathname-file outfile)])
    156           (list-tabulate
    157            num
    158            (lambda (i) (make-pathname #f (sprintf "~A~A.c" file i))) ) ) ] ) )
    159138
    160139    (define (cputime) (##sys#fudge 6))
     
    230209          (##sys#read in infohook) ) )
    231210
    232     (when (or (< partitions 1) (not outfile))
    233         (set! partitions 1))
    234211    (when uunit
    235212      (set! unit-name (string->c-identifier (stringify (option-arg uunit)))) )
     
    253230      (set! emit-closure-info #f) )
    254231    (set! use-import-table (memq 'check-imports options))
     232    (let ((imps (collect-options 'import)))
     233      (when (pair? imps)
     234        (set! use-import-table #t)
     235        (for-each lookup-exports-file imps) ) )
    255236    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
    256237    (when (memq 'no-warnings options)
     
    279260      (register-feature! 'case-insensitive)
    280261      (case-sensitive #f) )
    281     (and-let* ([slevel (memq 'split-level options)])
    282       (set! split-level
    283         (let ([n (string->number (option-arg slevel))])
    284           (if (and n (<= 0 n 2))
    285               n
    286               (quit "invalid argument to `-split-level' option") ) ) ) )
    287262    (when kwstyle
    288263      (let ([val (option-arg kwstyle)])
     
    302277              ##sys#include-pathnames
    303278              ipath) )
    304     (set! ofilelist (outfile->list outfile partitions))
    305     (when (and outfile filename (any (cut string=? <> filename) ofilelist))
     279    (when (and outfile filename (string=? outfile filename))
    306280      (quit "source- and output-filename are the same") )
    307281
     
    613587                              (print-node "closure-converted" '|9| node3)
    614588
    615                               (when (and verbose
    616                                          outfile
    617                                          (not (> partitions 1)) )
    618                                 (printf "files to be generated: ~A~%" (string-intersperse ofilelist ", ")) )
    619                              
    620589                              (begin-time)
    621                               (receive (node literals lambdas) (prepare-for-code-generation node3 db partitions)
     590                              (receive (node literals lambdas) (prepare-for-code-generation node3 db)
    622591                                (end-time "preparation")
    623592
    624593                                (begin-time)
    625                                 (let loopfile [(lof ofilelist)
    626                                                (file-partition 0)]
    627                                   (let* ([outfile (and lof (car lof))]
    628                                          [out (if outfile (open-output-file outfile) (current-output-port))] )
    629                                     (unless quiet
    630                                       (printf "generating `~A' ...~%" outfile) )
    631                                     (generate-code
    632                                      literals lambdas out filename dynamic db
    633                                      (if (= partitions 1) #f file-partition))
    634                                     (when outfile (close-output-port out))
    635                                     (when (and lof (pair? (cdr lof)))
    636                                       (loopfile (cdr lof) (+ file-partition 1)))))
     594                                (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
     595                                  (unless quiet
     596                                    (printf "generating `~A' ...~%" outfile) )
     597                                  (generate-code literals lambdas out filename dynamic db)
     598                                  (when outfile (close-output-port out)))
    637599                                (end-time "code generation")
    638600                                (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
  • chicken/boot/CMakeLists.txt

    r1016 r1186  
    5252LIBRARY_SCM_TO_C(match)
    5353SIMPLE_SCM_TO_C(optimizer parameters tweaks)
    54 SIMPLE_SCM_TO_C(partition)
    5554LIBRARY_SCM_TO_C(pcre regex-common)
    5655LIBRARY_SCM_TO_C(posix)
  • chicken/build.scm

    r1063 r1186  
    11(define build-version 2)
    2 (define build-number 321)
     2(define build-number 324)
  • chicken/buildnumber

    r1063 r1186  
    1 321
     1324
  • chicken/c-backend.scm

    r1016 r1186  
    139139;;; Generate target code:
    140140
    141 (define (generate-code literals lambdas out source-file dynamic db file-partition)
     141(define (generate-code literals lambdas out source-file dynamic db)
    142142  (let ()
    143143
     
    151151    (define (uncommentify s) (string-translate* (->string s) '(("*/" . "* /"))))
    152152 
    153     (define (prefix-id)
    154       (if file-partition unique-id "") )       
    155 
    156153    ;; Compile a single expression
    157154    (define (expression node temps ll)
     
    171168               (else (bomb "bad immediate")) ) )
    172169
    173             ((##core#literal) (gen (prefix-id) "lf[" (first params) #\]))
     170            ((##core#literal) (gen "lf[" (first params) #\]))
    174171
    175172            ((if)
     
    183180
    184181            ((##core#proc)
    185              (gen "(C_word)"
    186                   (if (and (pair? (cdr params)) (cadr params)) "" (prefix-id))
    187                   (first params)) )
     182             (gen "(C_word)" (first params)) )
    188183
    189184            ((##core#bind)
     
    262257               (cond [block
    263258                      (if safe
    264                           (gen (prefix-id) "lf[" index "]")
    265                           (gen "C_retrieve2(" (prefix-id) "lf[" index "]," (c-ify-string (symbol->string (fourth params))) #\)) ) ]
    266                      [safe (gen "*((C_word*)" (prefix-id) "lf[" index "]+1)")]
    267                      [else (gen "C_retrieve(" (prefix-id) "lf[" index "])")] ) ) )
     259                          (gen "lf[" index "]")
     260                          (gen "C_retrieve2(lf[" index "]," (c-ify-string (symbol->string (fourth params))) #\)) ) ]
     261                     [safe (gen "*((C_word*)lf[" index "]+1)")]
     262                     [else (gen "C_retrieve(lf[" index "])")] ) ) )
    268263
    269264            ((##core#setglobal)
     
    271266                   [block (second params)] )
    272267               (if block
    273                    (gen "C_mutate(&" (prefix-id) "lf[" index "],")
    274                    (gen "C_mutate((C_word*)" (prefix-id) "lf[" index "]+1,") )
     268                   (gen "C_mutate(&lf[" index "],")
     269                   (gen "C_mutate((C_word*)lf[" index "]+1,") )
    275270               (expr (car subs) i)
    276271               (gen #\)) ) )
     
    280275                   [block (second params)] )
    281276               (cond [block
    282                       (gen (prefix-id) "lf[" index "]=")
     277                      (gen "lf[" index "]=")
    283278                      (expr (car subs) i)
    284279                      (gen #\;) ]
    285280                     [else
    286                       (gen "C_set_block_item(" (prefix-id) "lf[" index "],0,")
     281                      (gen "C_set_block_item(lf[" index "],0,")
    287282                      (expr (car subs) i)
    288283                      (gen #\)) ] ) ) )
     
    313308               (cond ((eq? '##core#proc (node-class fn))
    314309                      (let ([fpars (node-parameters fn)])
    315                         (gen #t
    316                              (if (and (pair? (cdr fpars)) (cadr fpars))
    317                                  ""
    318                                  (prefix-id) )
    319                              (first fpars)
    320                              #\( nf ",0,") )
     310                        (gen #t (first fpars) #\( nf ",0,") )
    321311                      (expr-args args i)
    322312                      (gen ");") )
     
    342332                               (expr fn i)
    343333                               (gen #\;) )
    344                              (gen #t (prefix-id) call-id #\()
     334                             (gen #t call-id #\()
    345335                             (unless customizable (gen nf #\,))
    346336                             (unless empty-closure (gen #\t nc #\,))
     
    379369                        (gen #t "goto loop;") ) )
    380370                     (else
    381                       (gen (prefix-id) call-id #\()
     371                      (gen call-id #\()
    382372                      (unless empty-closure (gen "t0,"))
    383373                      (expr-args subs i)
     
    394384                    (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))
    395385                    (fn (car subs)) )
    396                (gen (prefix-id) call-id #\()
     386               (gen call-id #\()
    397387               (when allocating
    398388                 (gen "C_a_i(&a," demand #\))
     
    523513    (define (declarations)
    524514      (let ((n (length literals)))
    525         (cond [(not file-partition)
    526                (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);") ]
    527               [(zero? file-partition)
    528                (gen #t #t "C_externexport C_PTABLE_ENTRY *" (prefix-id) "create_ptable(void);") ]
    529               [else
    530                (gen #t #t "C_externimport C_PTABLE_ENTRY *" (prefix-id) "create_ptable(void);") ] )
     515        (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
    531516        (for-each
    532517         (lambda (uu)
     
    535520         used-units)
    536521        (unless (zero? n)
    537           (cond [(not file-partition)
    538                  (gen #t #t "static C_TLS C_word lf[" n"];")]
    539                 [(zero? file-partition)
    540                  (gen #t #t "C_TLS C_word " (prefix-id) "lf[" n"];")]
    541                 [else
    542                  (gen #t #t "C_externimport C_TLS C_word " (prefix-id) "lf[" n"];")]))))
     522          (gen #t #t "static C_TLS C_word lf[" n"];") ) ) )
    543523 
    544524    (define (prototypes)
     
    552532                  [varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)]
    553533                  [id (lambda-literal-id ll)]
    554                   [partition (lambda-literal-partition ll)]
    555                   [in-partition (or (not file-partition) (= file-partition partition))]
    556                   [in-partition* (and in-partition file-partition)]
    557                   [out-partition (and file-partition (not (= file-partition partition)))]
    558534                  [rest (lambda-literal-rest-argument ll)]
    559535                  [rest-mode (lambda-literal-rest-argument-mode ll)]
     
    569545              (lambda-literal-callee-signatures ll) )
    570546             (cond [(not (eq? 'toplevel id))
    571                     (gen "C_noret_decl(" (prefix-id) id ")" #t)
    572                     (cond [in-partition* (gen "C_externexport ")]
    573                           [in-partition (gen "static ")]                       
    574                           [else (gen "C_externimport ")])
     547                    (gen "C_noret_decl(" id ")" #t)
     548                    (gen "static ")
    575549                    (gen (if direct "C_word " "void "))
    576550                    (if customizable
    577551                        (gen "C_fcall ")
    578552                        (gen "C_ccall ") )
    579                     (gen (prefix-id) id) ]
     553                    (gen id) ]
    580554                   [else
    581555                    (let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
    582556                      (gen "C_noret_decl(C_" uname ")" #t)
    583                       (when (and emit-unsafe-marker (or (not file-partition) (zero? file-partition)))
     557                      (when emit-unsafe-marker
    584558                        (gen "C_externexport void C_dynamic_and_unsafe(void) {}" #t) )
    585                       (cond [in-partition (gen "C_externexport void C_ccall ")]
    586                             [else (gen "C_externimport void C_ccall ")])
     559                      (gen "C_externexport void C_ccall ")
    587560                      (gen "C_" uname) ) ] )
    588561             (gen #\()
     
    596569                    (if (not (eq? rest-mode 'none))
    597570                        (begin
    598                           (gen #t "C_noret_decl(" (prefix-id) id ")"
    599                                #t "static void C_ccall " (prefix-id) id "r(")
     571                          (gen #t "C_noret_decl(" id ")"
     572                               #t "static void C_ccall " id "r(")
    600573                          (apply gen varlist)
    601574                          (gen ",C_word t" (+ n 1) ") C_noret;") ) ) ]
     
    662635                      (gen #t "C_regparm static void C_fcall tr" id "(void *dummy){")
    663636                      (restore argc)
    664                       (gen #t (prefix-id) id #\()
     637                      (gen #t id #\()
    665638                      (let ([al (make-argument-list argc "t")])
    666639                        (apply gen (intersperse al #\,)) )
     
    690663           [lits literals (cdr lits)] )
    691664          ((null? lits))
    692         (gen-lit (car lits) (sprintf "~Alf[~s]" (prefix-id) i) #t) ) )
     665        (gen-lit (car lits) (sprintf "lf[~s]" i) #t) ) )
    693666
    694667    (define (bad-literal lit)
     
    834807         (let* ([n (lambda-literal-argument-count ll)]
    835808                [id (lambda-literal-id ll)]
    836                 [partition (lambda-literal-partition ll)]
    837                 [in-partition (or (not file-partition) (= file-partition partition))]
    838                 [in-partition* (and in-partition file-partition)]
    839                 [out-partition (and file-partition (not (= file-partition partition)))]
    840809                [rname (real-name id db)]
    841810                [demand (lambda-literal-allocated ll)]
     
    860829           (gen "/* " (cleanup rname) " */" #t)
    861830           (cond [(not (eq? 'toplevel id))
    862                   (cond [in-partition* (gen "C_externexport ")]
    863                         [in-partition (gen "static ")]                       
    864                         [else (gen "C_externimport ")])
     831                  (gen "static ")
    865832                  (gen (if direct "C_word " "void "))
    866833                  (if customizable
    867834                      (gen "C_fcall ")
    868835                      (gen "C_ccall ") )
    869                   (gen (prefix-id) id) ]
     836                  (gen id) ]
    870837                 [else
    871838                  (gen "static C_TLS int toplevel_initialized=0;")
     
    933900                    (gen #t "a=C_alloc(" demand ");")
    934901                    (when (not (zero? llen))
    935                       (gen #t "C_initialize_lf(" (prefix-id) "lf," llen ");")
     902                      (gen #t "C_initialize_lf(lf," llen ");")
    936903                      (literal-frame)
    937                       (gen #t "C_register_lf2(" (prefix-id) "lf," llen "," (prefix-id) "create_ptable());") ) ) ]
     904                      (gen #t "C_register_lf2(lf," llen ",create_ptable());") ) ) ]
    938905                 [rest
    939906                  (gen #t "va_list v;")
     
    982949                    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr" n #\r)
    983950                    (when (eq? rest-mode 'vector) (gen #\v))
    984                     (gen ",(void*)" (prefix-id) id "r")
     951                    (gen ",(void*)" id "r")
    985952                    (when (> nec 0)
    986953                      (gen #\, nec #\,)
     
    992959                      [(list #f) (gen #t "t" n "=C_restore_rest(a,C_rest_count(0));")]
    993960                      [(vector) (gen #t "t" n "=C_restore_rest_vector(a,C_rest_count(0));")] )
    994                     (gen #t (prefix-id) id "r(")
     961                    (gen #t id "r(")
    995962                    (apply gen (intersperse (make-argument-list n "t") #\,))
    996963                    (gen ",t" n ");}}")
    997964                    ;; Create secondary routine (no demand-check or argument-count-parameter):
    998                     (gen #t #t "static void C_ccall " (prefix-id) id "r(")
     965                    (gen #t #t "static void C_ccall " id "r(")
    999966                    (apply gen varlist)
    1000967                    (gen ",C_word t" n "){")
     
    1009976                    (if customizable
    1010977                        (gen id ",NULL")
    1011                         (gen n ",(void*)" (prefix-id) id) )
     978                        (gen n ",(void*)" id) )
    1012979                    (when (> nec 0)
    1013980                      (gen #\, nec #\,)
     
    1021988            ll)
    1022989           (gen #\}) ) )
    1023        (filter
    1024         (lambda (ll)
    1025           (let* ([partition (lambda-literal-partition ll)]
    1026                  [in-partition (or (not file-partition) (= file-partition partition))])
    1027             in-partition))
    1028         lambdas)) )
     990       lambdas) )
    1029991
    1030992    (debugging 'p "code generation phase...")
     
    10391001    (setup-quick-namespace-list)
    10401002    (procedures)
    1041     (when (or (not file-partition) (zero? file-partition))
    1042       (emit-procedure-table-info lambdas source-file file-partition (prefix-id)) )
     1003    (emit-procedure-table-info lambdas source-file)
    10431004    (trailer) ) )
    10441005
     
    10461007;;; Emit prrocedure table:
    10471008
    1048 (define (emit-procedure-table-info lambdas sf file-partition pref)
     1009(define (emit-procedure-table-info lambdas sf)
    10491010  (gen #t #t "#ifdef C_ENABLE_PTABLES"
    10501011       #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambdas)) "] = {")
     
    10531014       (gen #t "{NULL,NULL}};") )
    10541015    (let ((id (lambda-literal-id (car ll))))
    1055       (gen #t "{\"" pref id sf "\",(void*)")
     1016      (gen #t "{\"" id sf "\",(void*)")
    10561017      (if (eq? 'toplevel id)
    10571018          (if unit-name
    10581019              (gen "C_" unit-name "_toplevel},")
    10591020              (gen "C_toplevel},") )
    1060           (gen pref id "},") ) ) )
     1021          (gen id "},") ) ) )
    10611022  (gen #t "#endif")
    1062   (if file-partition
    1063       (gen #t #t "C_PTABLE_ENTRY *" pref "create_ptable(void)")
    1064       (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)") )
     1023  (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")
    10651024  (gen "{" #t "#ifdef C_ENABLE_PTABLES"
    10661025       #t "return ptable;"
  • chicken/c-platform.scm

    r1016 r1186  
    132132(define valid-compiler-options-with-argument
    133133  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    134           inline-limit profile-name disable-warning emit-exports
    135     prelude postlude prologue epilogue nursery extend feature compress-literals split-level
    136     heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path split) )
     134          inline-limit profile-name disable-warning emit-exports import
     135    prelude postlude prologue epilogue nursery extend feature compress-literals
     136    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    137137
    138138
     
    186186    ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list
    187187    ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range?
    188     ##sys#fudge ##sys#immediate? ##sys#direct-return
     188    ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
    189189    ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
    190190    ##sys#bytevector? ##sys#make-vector ##sys#setter
  • chicken/chicken-setup.scm

    r1063 r1186  
    3838  (uses srfi-1 regex utils posix tcp match srfi-18)
    3939  (export move-file run:execute make/proc uninstall-extension install-extension install-program install-script
    40           setup-verbose-flag setup-install-flag installation-prefix find-library
     40          setup-verbose-flag setup-install-flag installation-prefix find-library find-header
    4141          program-path remove-file* patch yes-or-no? setup-build-directory setup-root-directory create-directory
    4242          test-compile copy-file run-verbose) )
     
    138138(define *proxy-host* #f)
    139139(define *proxy-port* #f)
     140(define *example-directory* (make-pathname (chicken-home) "examples"))
     141
    140142
    141143; Repository-format:
     
    451453    (run (csc -O2 -no-trace -s ,filename -emit-exports ,(make-pathname #f id "exports")))
    452454    (when (setup-install-flag)
    453       (unless *windows* (run (,*remove-command* ,(make-pathname (repo-path) ,so))))
     455      (unless *windows* (run (,*remove-command* ,(make-pathname (repo-path) so))))
    454456      (run (,*copy-command* ,so ,(repo-path)))
    455457      (write-info id (list (make-pathname (repository-path) so)) '()) )
     
    539541                           to) )
    540542                       files) ) )
    541       (when (assq 'documentation info) (set! *rebuild-doc-index* #t))
     543      (and-let* ((docs (assq 'documentation info)))
     544        (print "\n* The following documentation files have been installed in " (doc-index) ":")
     545        (for-each (cut print "  * " <>) (cdr docs))
     546        (newline)
     547        (set! *rebuild-doc-index* #t))
     548      (and-let* ((exs (assq 'examples info)))
     549        (print "\n* The following example files have been installed in " *example-directory* ":")
     550        (for-each
     551         (lambda (f)
     552           (copy-file f (make-pathname *example-directory* f))
     553           (print "  * " f) )
     554         (cdr exs))
     555        (newline) )
    542556      (write-info id dests info) ) ) )
    543557
     
    632646                (conc name ".lib")
    633647                (conc "-l" name) ) ) )
     648
     649(define (find-header name)
     650  (test-compile
     651   (sprintf "#include <~a>\nint main() { return 0; }\n" name)
     652   compile-only: #t) )
    634653
    635654(define (http-get-path-request path fname host)
  • chicken/chicken.1

    r1016 r1186  
    225225.B \-help
    226226Print a summary of available options and the format of the command-line parameters and exit the compiler.
     227
     228.TP
     229.BI \-import\ pathname
     230Read exports from linked or loaded libraries from given file. Implies
     231.B \-check\-imports
    227232
    228233.TP
     
    381386
    382387.TP
    383 .BI \-split\ number
    384 Split output into several C files. So for a source file named
    385 .I name
    386 the compiler will generate C files named
    387 .I name0\,
    388 .I \.\.\.\,
    389 .I nameN\-1
    390 
    391 .TP
    392 .BI \-split\-level\ number
    393 Specifies how hard the partitioning algorithm should work (should be 0, 1 or 2).
    394 
    395 .TP
    396388.B \-to\-stdout
    397389Write compiled code to standard output instead of creating a
  • chicken/chicken.h

    r1016 r1186  
    12811281C_fctexport void C_ccall C_software_version(C_word c, C_word closure, C_word k) C_noret;
    12821282C_fctexport void C_ccall C_build_platform(C_word c, C_word closure, C_word k) C_noret;
    1283 C_fctexport C_word C_fcall C_flat_directory_install() C_regparm;
    12841283C_fctexport void C_ccall C_c_runtime(C_word c, C_word closure, C_word k) C_noret;
    12851284C_fctexport void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc) C_noret;
  • chicken/chicken.scm

    r1016 r1186  
    3636(declare
    3737  (uses extras srfi-1 match srfi-4 utils support compiler optimizer driver platform backend
    38         easyffi partition lolevel tinyclos)
     38        easyffi lolevel tinyclos)
    3939  (run-time-macros) )
    4040
  • chicken/chicken.texi

    r1063 r1186  
    11\input texinfo @c -*-texinfo-*-
    22@setfilename chicken.info
    3 @settitle CHICKEN - A practical and portable Scheme system. Version 2, Build 321
     3@settitle CHICKEN - A practical and portable Scheme system. Version 2, Build 324
    44
    55@ifnottex
     
    5757@dircategory The Algorithmic Language Scheme
    5858@direntry
    59 * CHICKEN: (chicken).          A pratical and portable Scheme system (Version 2, Build 321).
     59* CHICKEN: (chicken).          A pratical and portable Scheme system (Version 2, Build 324).
    6060@end direntry
    6161
     
    6464@subtitle A practical and portable Scheme system
    6565@subtitle User's Manual
    66 @subtitle Version 2, Build 321
     66@subtitle Version 2, Build 324
    6767@author Felix L. Winkelmann
    6868@end titlepage
     
    7979
    8080CHICKEN - A practical and portable Scheme system
    81 User's manual (Version 2, Build 321)
     81User's manual (Version 2, Build 324)
    8282
    8383(c) 2000-2006, Felix L. Winkelmann
     
    518518@item F
    519519show output of ``easy'' FFI parser
    520 @item P
    521 show execution of outer partitioning
    522 @item Q
    523 show execution of middle partitioning
    524 @item R
    525 show execution of inner partitioning
    526520@item M
    527521show unit-information and syntax-/runtime-requirements
     
    699693parameters and exit the compiler.
    700694
     695@item -import FILENAME
     696
     697Read exports from linked or loaded libraries from given file. See also
     698@code{-check-imports}. This is equivalent to declaring
     699
     700@verbatim
     701(declare (import FILENAME))
     702@end verbatim
     703
     704Implies @code{-check-imports}.
     705
    701706@item -include-path PATHNAME
    702707
     
    835840at run-time. By default macros are not available at
    836841run-time.
    837 
    838 @item -split NUMBER
    839 Splits output into multiple C files that can be compiled separately. The generated
    840 C files will be named @code{filename0}, ..., @code{filename<NUMBER-1>} with as many
    841 files as given in @code{NUMBER}.
    842 
    843 @item -split-level NUMBER
    844 Specifies how hard the partitioning algorithm should work:
    845 
    846 @itemize
    847 @item 0 Exit after first iteration (quickest)
    848 @item 1 Exit when cost does not decrease by at least one-half (the default)
    849 @item 2 Exit when cost does not change
    850 @end itemize
    851842
    852843@item -to-stdout
     
    16691660Variables in required-formal-arguments are bound to successive actual arguments starting with the first actual argument. It shall be an error if there are fewer actual arguments than required-formal-arguments.
    16701661
    1671 Next, variables in optional-formal-arguments are bound to any remaining actual arguments. If there are fewer remaining actual arguments than optional-formal-arguments, then variables are bound to the result of the evaluation of initializer, if one w otherise to @code{#f}. The initializer is evaluated in an environment in which all previous formal arguments have been bound.
    1672 
    1673 If there is a rest-formal-argument, then it is bound to a list of all remaining actual arguments. The remaining actual arguments are also eligible to be bound to keyword-formal-arguments. If there is no rest-formal-argument and there are no keyword- the i shall be an error if there are any remaining actual arguments.
    1674 
    1675 If @code{#!key} was specified in the formal-argument-list, there shall be an even number of remaining actual arguments. These are interpreted as a series of pairs, where the first member of each pair is a keyword specifying the argument name, and thorrespnding value. It shall be an error if the first member of a pair is not a keyword. It shall be an error if the argument name is not the same as a variable in a keyword-formal-argument, unless there is a rest-formal-argument. If the same argument name occurs more than once in the list of actual arguments, then the first value is used. If there is no actual argument for a particular keyword-formal-argument, then the variable is bound to the result of evaluating initializer if one was specified or @code{#f}. Te initializer is evaluated in an environment in which all previous formal arguments have been bound.
     1662Next, variables in optional-formal-arguments are bound to any remaining actual arguments. If there are fewer remaining actual arguments than optional-formal-arguments, then variables are bound to the result of the evaluation of initializer, if one w other to @code{#f}. The initializer is evaluated in an environment in which all previous formal arguments have been bound.
     1663
     1664If there is a rest-formal-argument, then it is bound to a list of all remaining actual arguments. The remaining actual arguments are also eligible to be bound to keyword-formal-arguments. If there is no rest-formal-argument and there are no keyword- the iall be an error if there are any remaining actual arguments.
     1665
     1666If @code{#!key} was specified in the formal-argument-list, there shall be an even number of remaining actual arguments. These are interpreted as a series of pairs, where the first member of each pair is a keyword specifying the argument name, and thorrespng value. It shall be an error if the first member of a pair is not a keyword. It shall be an error if the argument name is not the same as a variable in a keyword-formal-argument, unless there is a rest-formal-argument. If the same argument name occurs more than once in the list of actual arguments, then the first value is used. If there is no actual argument for a particular keyword-formal-argument, then the variable is bound to the result of evaluating initializer if one was specified or @code{#f}. Teiiializer is evaluated in an environment in which all previous formal arguments have been bound.
    16761667
    16771668It shall be an error for an @code{<ident>} to appear more than once in a formal-argument-list.
     
    30082999@end deffn
    30093000
     3001@deffn {declaration specifier} constant
     3002@lisp
     3003(constant SYMBOL ...)
     3004@end lisp
     3005Declares the procedures with the names @code{SYMMBOL ...} as constant, that is, as not having any
     3006side effects. This can help the compiler to remove non-side-effecting expressions.
     3007@end deffn
     3008
    30103009@deffn {declaration specifier} export
    30113010@lisp
     
    30473046Disable warnings of type @code{CLASS ...} (equivalent to the @code{-disable-warning CLASS}
    30483047compiler option).
     3048@end deffn
     3049
     3050@deffn {declaration specifier} import
     3051@lisp
     3052(import SYMBOL-OR-STRING ...)
     3053@end lisp
     3054Adds new imports to the list of externally available toplevel variables. Arguments to this declaration
     3055may be either strings (designating @code{.exports} files, without the file-extension) or symbols
     3056which directly designate imported variables.
    30493057@end deffn
    30503058
     
    1186811876@end deffn
    1186911877
     11878@deffn {property} examples
     11879@lisp
     11880(examples FILENAME ...)
     11881@end lisp
     11882Copies the given files into the examples directory, which is usually
     11883@code{$prefix/share/chicken/examples} (equivalent to @code{$CHICKEN_HOME/examples}
     11884or @code{(make-pathname (chicken-home) "examples")}).
     11885@end deffn
     11886
    1187011887@deffn {property} exports
    1187111888@lisp
     
    1197511992C function that must be provided by the library. If no such library was found or the function could not
    1197611993be resolved, @code{#f} is returned.
     11994@end deffn
     11995
     11996@deffn {procedure} find-header
     11997@lisp
     11998(find-header NAME)
     11999@end lisp
     12000Returns @code{#t} if a C include-file with the given name is available, or @code{#f} otherwise.
    1197712001@end deffn
    1197812002
  • chicken/compiler.scm

    r1063 r1186  
    7777; (emit-exports <string>)
    7878; (keep-shadowed-macros)
     79; (import <symbol-or-string> ...)
    7980;
    8081;   <type> = fixnum | generic
     
    257258  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    258259  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    259   installation-home decompose-lambda-list external-to-pointer defconstant-bindings
     260  installation-home decompose-lambda-list external-to-pointer defconstant-bindings constant-declarations
    260261  foreign-type-table-size copy-node! error-is-extended-binding toplevel-scope toplevel-lambda-id
    261262  unit-name insert-timer-checks used-units external-variables require-imports-flag custom-declare-alist
     
    277278  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub
    278279  expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive
    279   factor partition-fm process-declaration external-protos-first basic-literal? emit-line-info
     280  process-declaration external-protos-first basic-literal? emit-line-info
    280281  transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker
    281282  debugging-chicken bomb check-signature posq stringify symbolify flonum? build-lambda-list
     
    370371(define use-import-table #f)
    371372(define undefine-shadowed-macros #t)
     373(define constant-declarations '())
    372374
    373375
     
    11521154                  (alist-update! ns (lset-union eq? oldsyms (cdr syms)) namespace-table eq?) ) )
    11531155              (quit "invalid arguments to `namespace' declaration: ~S" spec) ) ) )
     1156       ((constant)
     1157        (let ((syms (cdr spec)))
     1158          (if (every symbol? syms)
     1159              (set! constant-declarations (append syms constant-declarations))
     1160              (quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
     1161       ((import)
     1162        (let-values (((syms strs)
     1163                      (partition
     1164                       (lambda (x)
     1165                         (cond ((symbol? x) #t)
     1166                               ((string? x) #f)
     1167                               (else (quit "argument to `import' declaration is not a string or symbol" x)) ) )
     1168                       (cdr spec) ) ) )
     1169          (set! use-import-table #t)
     1170          (for-each (cut ##sys#hash-table-set! import-table <> "<here>") syms)
     1171          (for-each lookup-exports-file strs) ) )
    11541172       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    11551173     '(##core#undefined) ) ) )
     
    20322050  rest-argument-mode                    ; #f | LIST | VECTOR | UNUSED
    20332051  body                                  ; expression
    2034   direct                                ; boolean
    2035   partition)                            ; integer
     2052  direct)                               ; boolean
    20362053 
    2037 (define (prepare-for-code-generation node db partitions)
     2054(define (prepare-for-code-generation node db)
    20382055  (let ([literals '()]
    20392056        [lambdas '()]
     
    21722189                           rest-mode
    21732190                           body
    2174                            direct
    2175                            0)
     2191                           direct)
    21762192                          lambdas) )
    21772193                  (set! looping lping)
     
    22782294                       (else (bomb "bad immediate (prepare)")) )
    22792295                 '() ) )
    2280 
    2281     (define (partition-phase! partitions)
    2282       (define (set-inregion! cells partition)
    2283         (for-each
    2284           (lambda (c)
    2285             (graph-cell-info$$-inregion-set!
    2286               (graph-cell$$-info c)
    2287               (eq? (graph*partition c) partition)))
    2288           cells))
    2289       (let [(callgraph (make-graph$ eq?))]
    2290         (debugging 'p "partitioning phase...")
    2291         ;; init call graph
    2292         (for-each
    2293           (lambda (l)
    2294             (graph$-add-cell! callgraph (make-graph-cell$ (lambda-literal-id l))))
    2295           lambdas)
    2296         (##sys#hash-table-for-each
    2297         (lambda (sym plist)
    2298           (let loop [(es plist)]
    2299             (if (and (pair? es)
    2300                      (eq? (caar es) 'contains))
    2301                 (for-each
    2302                   (lambda (o)
    2303                     (let [(symcell (graph$-get callgraph sym))]
    2304                       (and symcell ;; toplevel et al aren't in lambdas
    2305                            (graph-cell$-add-undirected-edge!
    2306                              symcell
    2307                              (graph$-get callgraph o)))))
    2308                   (cdar es)))
    2309             (and (pair? es) (loop (cdr es)))))
    2310         db)
    2311         ;; partition recursion.  i threw together something with
    2312         ;; primes to decompose any partition into bi-partitions.  i am
    2313         ;; sure there is a better way.
    2314         (randomize 20040619) ;; make partition repeatable
    2315         (define partition-level 0)
    2316         (define partition-index 0)
    2317         (let pway ([factors (sort (factor partitions) <)]
    2318                    [cells (graph$->list callgraph)])
    2319           (cond-expand [testing
    2320                         (let loop ([n partition-level])
    2321                           (and (> n 0) (display "  ") (loop (sub1 n)))) ]
    2322                        [else] )
    2323           (set! partition-level (add1 partition-level))
    2324           (cond
    2325            ;; terminate and update
    2326            [(null? factors)
    2327             (for-each
    2328              (lambda (cell)
    2329                (let* [(id (graph*id cell))
    2330                       (ll (member id lambdas
    2331                                   (lambda (x ei)
    2332                                     (eq? x (lambda-literal-id ei)))))]
    2333                  (and ll
    2334                       (lambda-literal-partition-set!
    2335                        (car ll)
    2336                        partition-index))))
    2337              cells)
    2338             (set! partition-index (add1 partition-index))]
    2339            ;; just continue if 1
    2340            [(= (car factors) 1)
    2341             (pway (cdr factors) cells)]
    2342            ;; bi-partition, balanced 50/50
    2343            [(= (car factors) 2)
    2344             (partition-fm cells
    2345                           graph*id graph*color graph*color-set!
    2346                           graph*partition graph*partition-move!
    2347                           graph*neighbours
    2348                           graph*gain
    2349                           (lambda () (graph*cost callgraph))
    2350                           (lambda (w n#f n#t)
    2351                             (graph*balance cells
    2352                                            (length cells)
    2353                                            w n#f n#t))
    2354                           ;; 50/50
    2355                           '(1 . 1)
    2356                           10)
    2357 
    2358             (let ([bpart#f (map (complement graph*partition) cells)]
    2359                   [bpart#t (map graph*partition cells)])
    2360               ;; descend binary tree
    2361              
    2362               (set-inregion! cells #f)
    2363               (pway (cdr factors) (compress bpart#f cells))
    2364              
    2365               (set-inregion! cells #t)
    2366               (pway (cdr factors) (compress bpart#t cells)))
    2367             ]
    2368            ;; bi-partition, but unbalanced
    2369            [else
    2370             (partition-fm cells
    2371                           graph*id graph*color graph*color-set!
    2372                           graph*partition graph*partition-move!
    2373                           graph*neighbours
    2374                           graph*gain
    2375                           (lambda () (graph*cost callgraph))
    2376                           (lambda (w n#f n#t)
    2377                             (graph*balance cells
    2378                                            (length cells)
    2379                                            w n#f n#t))                   
    2380                           ;; split into 1:(prime-1) ratio
    2381                           (cons 1 (sub1 (car factors)))
    2382                           10)
    2383             (let ([bpart#f (map (complement graph*partition) cells)]
    2384                   [bpart#t (map graph*partition cells)])
    2385               ;;; modify binary tree
    2386              
    2387               (set-inregion! cells #f)
    2388               (pway (cons 1 (cdr factors))
    2389                     (compress bpart#f cells))
    2390              
    2391               (set-inregion! cells #t)
    2392               (pway (append (factor (sub1 (car factors))) (cdr factors))
    2393                     (compress bpart#t cells)))
    2394             ]
    2395            )
    2396           (set! partition-level (sub1 partition-level))
    2397           )
    2398         (and #f ;; debugging
    2399              (for-each
    2400               (lambda (l)
    2401                 (display (lambda-literal-id l))
    2402                 (display " in ")
    2403                 (display (lambda-literal-partition l))
    2404                 (newline))
    2405               lambdas))
    2406         (randomize);; reset random
    2407         ))
    24082296   
    24092297    (debugging 'p "preparation phase...")
    2410     (let* ((node2 (walk node '() #f '()))
    2411            (t0 (##sys#fudge 6)) )
    2412       (partition-phase! partitions)
    2413       (debugging 'b (sprintf "  time needed for partitioning: ~A ms" (- (##sys#fudge 6) t0)))
     2298    (let ((node2 (walk node '() #f '())))
    24142299      (debugging 'o "fast box initializations" fastinits)
    24152300      (debugging 'o "fast global references" fastrefs)
    24162301      (debugging 'o "fast global assignments" fastsets)
    24172302      (values node2 literals lambdas) ) ) )
    2418 
    2419 
    2420 ;; factor - Jonah Beckford - slimmed down from SLIB. -*- Hen -*-
    2421 
    2422 ;;;; "factor.scm" factorization, prime test and generation
    2423 ;;; Copyright (C) 1991, 1992, 1993, 1998 Aubrey Jaffer
    2424 ;
    2425 ;Permission to copy this software, to modify it, to redistribute it,
    2426 ;to distribute modified versions, and to use it for any purpose is
    2427 ;granted, subject to the following restrictions and understandings.
    2428 ;
    2429 ;1.  Any copy made of this software must include this copyright notice
    2430 ;in full.
    2431 ;
    2432 ;2.  I have made no warranty or representation that the operation of
    2433 ;this software will be error-free, and I am under no obligation to
    2434 ;provide any services, by way of maintenance, update, or otherwise.
    2435 ;
    2436 ;3.  In conjunction with products arising from the use of this
    2437 ;material, there shall be no use of my name in any advertising,
    2438 ;promotional, or sales literature without prior written consent in
    2439 ;each case.
    2440 
    2441 ;;(declare (unit factor)
    2442 ;;       (uses lolevel)
    2443 ;;       (export factor))
    2444 
    2445 ;;; prime:products are products of small primes.
    2446 ;;; was (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps))
    2447 (declare
    2448   (hide primes-gcd? prime:prime-sqr prime:products prime:sieve prime:f prime:fo prime:fe) )
    2449 
    2450 (define (primes-gcd? n comps)
    2451   (not (let mapf ((lst comps))
    2452          (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst)))))))
    2453 (define prime:prime-sqr 121)
    2454 (define prime:products '(105))
    2455 (define prime:sieve (vector 0 0 1 1 0 1 0 1 0 0 0))
    2456 (letrec ((lp (lambda (comp comps primes nexp)
    2457                (cond ((< comp (quotient (##sys#fudge 21) nexp))
    2458                       (let ((ncomp (* nexp comp)))
    2459                         (lp ncomp comps
    2460                             (cons nexp primes)
    2461                             (next-prime nexp (cons ncomp comps)))))
    2462                      ((< (quotient comp nexp) (* nexp nexp))
    2463                       (set! prime:prime-sqr (* nexp nexp))
    2464                       (set! prime:sieve (make-vector nexp 0))
    2465                       (for-each (lambda (prime)
    2466                                   (vector-set! prime:sieve prime 1))
    2467                                 primes)
    2468                       (set! prime:products (reverse (cons comp comps))))
    2469                      (else
    2470                       (lp nexp (cons comp comps)
    2471                           (cons nexp primes)
    2472                           (next-prime nexp (cons comp comps)))))))
    2473          (next-prime (lambda (nexp comps)
    2474                        (set! comps (reverse comps))
    2475                        (do ((nexp (+ 2 nexp) (+ 2 nexp)))
    2476                            ((not (primes-gcd? nexp comps)) nexp)))))
    2477   (lp 3 '() '(2 3) 5))
    2478 ;;;;Lankinen's recursive factoring algorithm:
    2479 ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler)
    2480 
    2481 ;                  |  undefined if n<0,
    2482 ;                  |  (u,v) if n=0,
    2483 ;Let f(u,v,b,n) := | [otherwise]
    2484 ;                  |  f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd
    2485 ;                  |  f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
    2486 
    2487 ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
    2488 
    2489 ;It may be illuminating to consider the relation of the Lankinen function in
    2490 ;a `computational hierarchy' of other factoring functions.*  Assumptions are
    2491 ;made herein on the basis of conventional digital (binary) computers.  Also,
    2492 ;complexity orders are given for the worst case scenarios (when the number to
    2493 ;be factored is prime).  However, all algorithms would probably perform to
    2494 ;the same constant multiple of the given orders for complete composite
    2495 ;factorizations.
    2496 
    2497 ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
    2498 ;     O(n*log2(n)) in space.
    2499 ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
    2500 ;    number thm), requiring an array of size proportional to n with log2(n)
    2501 ;    space for each entry.
    2502 
    2503 ;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in
    2504 ;     space.
    2505 ;Pf: It tests all odd factors less than the square root of n (about
    2506 ;    sqrt(n)/2), with log2(n) time for each division.  It requires only
    2507 ;    log2(n) space for the number and divisors.
    2508 
    2509 ;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n))
    2510 ;     in space.
    2511 ;Pf: The algorithm is easily modified to seach only for factors p<q for all
    2512 ;    pq=m.  Then the recursive call tree forms a geometric progression
    2513 ;    starting at one, and doubling until reaching sqrt(n)/2, or a length of
    2514 ;    log2(sqrt(n)/2).  From the formula for a geometric progression, there is
    2515 ;    a total of about 2^log2(sqrt(n)/2) = sqrt(n)/2 calls.  Assuming that
    2516 ;    addition, subtraction, comparison, and multiplication/division by two
    2517 ;    occur in constant time, this implies O(sqrt(n)/2) time and a
    2518 ;    O((sqrt(n)/2)*log2(n)) requirement of stack space.
    2519 
    2520 (define (prime:f u v b n)
    2521   (if (<= n 0)
    2522       (cond ((negative? n) #f)
    2523             ((= u 1) #f)
    2524             ((= v 1) #f)
    2525             ; Do both of these factors need to be factored?
    2526             (else (append (or (prime:f 1 1 2 (quotient (- u 1) 2))
    2527                               (list u))
    2528                           (or (prime:f 1 1 2 (quotient (- v 1) 2))
    2529                               (list v)))))
    2530       (if (even? n)
    2531           (or (prime:f u v (+ b b) (quotient n 2))
    2532               (prime:f (+ u b) (+ v b) (+ b b) (quotient (- n (+ u v b)) 2)))
    2533           (or (prime:f (+ u b) v (+ b b) (quotient (- n v) 2))
    2534               (prime:f u (+ v b) (+ b b) (quotient (- n u) 2))))))
    2535 
    2536 (define (prime:fo m)
    2537   (let* ((s (gcd m (car prime:products)))
    2538          (r (quotient m s)))
    2539     (if (= 1 s)
    2540         (or (prime:f 1 1 2 (quotient (- m 1) 2)) (list m))
    2541         (append
    2542          (if (= 1 r) '()
    2543              (or (prime:f 1 1 2 (quotient (- r 1) 2)) (list r)))
    2544          (or (prime:f 1 1 2 (quotient (- s 1) 2)) (list s))))))
    2545 
    2546 (define (prime:fe m)
    2547   (if (even? m)
    2548       (cons 2 (prime:fe (quotient m 2)))
    2549       (if (eqv? 1 m)
    2550           '()
    2551           (prime:fo m))))
    2552 
    2553 ;;@body
    2554 ;;Returns a list of the prime factors of @1.  The order of the
    2555 ;;factors is unspecified.  In order to obtain a sorted list do
    2556 ;;@code{(sort! (factor @var{k}) <)}.
    2557 (define (factor k)
    2558   (case k
    2559     ((-1 0 1) (list k))
    2560     (else (if (negative? k)
    2561               (cons -1 (prime:fe (- k)))
    2562               (prime:fe k)))))
  • chicken/configure.in

    r1063 r1186  
    33dnl (originally by Doug Quale)
    44
    5 AC_INIT(chicken,2.321)
     5AC_INIT(chicken,2.324)
    66BINARY_VERSION=1
    77AC_PREREQ(2.50)
  • chicken/csc.scm.in

    r1016 r1186  
    6161(define home
    6262  (or (getenv "CHICKEN_HOME")
    63       (if flat-directory-install
     63      (if (flat-directory-install)
    6464          (quit "`CHICKEN_HOME' environment variable not set - please set it to the directory where CHICKEN is installed")
    6565          (prefix "" "share" "%pkgdatadir%") ) ) )
     
    6868
    6969(begin
    70   (if flat-directory-install
     70  (if (flat-directory-install)
    7171      (define translator (homize "chicken"))
    7272      (define translator (prefix "chicken" "bin" "%bindir%/chicken")) )
     
    130130  '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
    131131    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
    132     -require-extension -split -split-level -inline-limit -profile-name -disable-warning
     132    -require-extension -inline-limit -profile-name -disable-warning -import
    133133    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -emit-exports
    134134    -compress-literals -ffi-define -ffi-include-path) )
     
    168168(define objc-mode #f)
    169169(define embedded #f)
    170 (define split #f)
    171170(define inquiry-only #f)
    172171(define show-cflags #f)
     
    179178      (define extra-libraries "")
    180179      (define extra-shared-libraries "")
    181       (if flat-directory-install
     180      (if (flat-directory-install)
    182181        (begin
    183182          (define default-library-files
     
    228227(define compile-options
    229228  (if win
    230     (if flat-directory-install
     229    (if (flat-directory-install)
    231230      (cons* "/I%CHICKEN_HOME%" "/DC_NO_PIC_NO_DLL" (if (eq? (c-runtime) 'dynamic) '("/MD") '()))
    232231      (cons* "/I%includedir%" "/DC_NO_PIC_NO_DLL" (if (eq? (c-runtime) 'dynamic) '("/MD") '()))
     
    284283    -o -output-file FILENAME    specifies target executable name
    285284    -I -include-path PATHNAME   specifies alternative path for included files
    286     -split NUMBER               split the output into smaller files
    287     -split-level NUMBER         how hard the compiler should try partitioning the output
    288285    -to-stdout                  write compiler to stdout (implies -t)
    289286    -s -shared -dynamic         generate dynamically loadable shared object file
     
    328325    -emit-exports FILENAME      write exported toplevel variables to FILENAME
    329326    -G  -check-imports          look for undefined toplevel variables
     327    -import FILENAME            read externally exported symbols from FILENAME
    330328
    331329  Optimization options:
     
    582580                (set! translator (car rest))
    583581                (set! rest (cdr rest)) ]
    584                [(-split)
    585                 (let ([n (car rest)])
    586                   (set! split
    587                     (let ([n (or (string->number n)
    588                                  (quit "bad argument `~A' to -split option" n) ) ] )
    589                       (when (< n 2)
    590                         (print "option `-split " n "' ignored.")
    591                         (set! n #f) )
    592                       n) )
    593                   (set! rest (cdr rest))
    594                   (t-options "-split" n) ) ]
    595582               [(-cc)
    596583                (check s rest)
     
    723710                    " ") ) )
    724711           (exit last-exit-code) )
    725          (let ([fcs (if split
    726                         (reverse
    727                          (map (lambda (i)
    728                                 (pathname-replace-file fc (string-append (pathname-file fc) (->string i))) )
    729                               (iota split) ) )
    730                         (list fc) ) ] )
    731            (set! c-files (append fcs c-files))
    732            (set! generated-c-files (append fcs generated-c-files)) )
     712         (set! c-files (append (list fc) c-files))
     713         (set! generated-c-files (append (list fc) generated-c-files))
    733714         (when (file-exists? cscf)
    734715           (with-input-from-file cscf
  • chicken/easyffi.scm

    r1016 r1186  
    4242  (disable-warning var)
    4343  (compress-literals)
     44  (no-procedure-checks)
    4445  (export parse-easy-ffi register-ffi-macro used-units foreign-declarations number-type
    4546          ffi-include-path-list ffi-dont-include
  • chicken/eval.scm

    r1016 r1186  
    7171     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
    7272     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
    73      open-output-string get-output-string
     73     open-output-string get-output-string make-parameter software-type software-version machine-type
     74     build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
     75     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
     76     ##sys#match-expression vector->list store-string open-input-string eval ##sys#gc
     77     with-exception-handler print-error-message read-char read ##sys#read-error
     78     ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
     79     ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
     80     repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
     81     symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
     82     ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
     83     ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
     84     file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
     85     dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
     86     port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
     87     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
     88     map string->keyword ##sys#abort
    7489     ##sys#macroexpand-0 ##sys#macroexpand-1-local) ) ] )
    7590
     
    14391454 'version
    14401455 (lambda (spec _)
     1456   (define (->string x)
     1457     (cond ((string? x) x)
     1458           ((symbol? x) (##sys#slot x 1))
     1459           ((number? x) (##sys#number->string x))
     1460           (else (error "invalid extension version" x)) ) )
    14411461   (match spec
    14421462     (('version id v)
  • chicken/extras.scm

    r1016 r1186  
    8282     ##sys#check-number ##sys#cons-flonum
    8383     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure
    84      ##sys#make-structure
     84     ##sys#make-structure make-parameter hash-table-set! ##sys#hash-new-len hash-table-ref
     85     hash-table-update! floor input-port? make-vector list->vector sort! merge! open-output-string
     86     get-output-string current-output-port ##sys#flush-output ##sys#write-char-0 newline
     87     ##sys#number->string display write ##sys#fragments->string list->string make-string string
     88     pretty-print-width ##sys#symbol->qualified-string ##extras#reverse-string-append ##sys#number?
     89     ##sys#procedure->string ##sys#pointer->string port? ##sys#user-print-hook char-name
     90     read open-input-string ##sys#peek-char-0 ##sys#read-char-0 ##sys#write-char call-with-input-file
     91     read-line reverse make-string ##sys#string-append random
    8592     ##sys#gcd ##sys#lcm ##sys#fudge ##sys#check-list ##sys#user-read-hook) ) ] )
    8693
  • chicken/library.scm

    r1016 r1186  
    109109     ##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer ##sys#user-print-hook
    110110     ##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
    111      ##sys#port-has-file-pointer? ##sys#infix-list-hook
    112      ##sys#intern-symbol ##sys#make-string ##sys#number?
     111     ##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
     112     ##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
     113     open-output-string get-output-string print-call-chain ##sys#symbol-has-toplevel-binding? repl
     114     argv condition-property-accessor ##sys#decorate-lambda ##sys#become! ##sys#lambda-decoration
     115     getter-with-setter ##sys#lambda-info ##sys#lambda-info->string open-input-string ##sys#gc
     116     ##sys#memory-info ##sys#make-c-string ##sys#find-symbol-table array:make-locative display
     117     newline string-append ##sys#with-print-length-limit write print vector-fill! ##sys#context-switch
     118     ##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
     119     ##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
     120     ##sys#apply-values ##sys#signal-hook ##sys#get-call-chain ##sys#really-print-call-chain
     121     string->keyword keyword? string->keyword getenv ##sys#number->string ##sys#copy-bytes
     122     call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
     123     ##sys#reverse-list->string reverse ##sys#inexact? list? string ##sys#char->utf8-string
     124     ##sys#update-errno ##sys#file-info close-output-port close-input-port ##sys#peek-unsigned-integer
     125     continuation-graft char-downcase string-copy remainder floor ##sys#exact? list->string
    113126     ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
    114127     ##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
     
    979992                               [else (err prefix)] ) )
    980993                    (err prefix) ) ) )
    981           (number->string counter) ) ) ) ) ) )
     994          (##sys#number->string counter) ) ) ) ) ) )
    982995
    983996
     
    15361549        (if (fx> len 0)
    15371550            (case (##core#inline "C_subchar" path 0)
    1538               ((#\~) (##sys#string-append (or (getenv "HOME") "") (##sys#substring path 1 len)))
     1551              ((#\~)
     1552               (let ((rest (##sys#substring path 1 len)))
     1553                 (if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1)))
     1554                     (##sys#string-append (or (getenv "HOME") "") rest)
     1555                     (##sys#string-append "/home/" rest) ) ) )
    15391556              ((#\$)
    15401557               (let loop ((i 1))
     
    24192436                  (outchr port #\|)
    24202437                  (let ([c (##core#inline "C_subchar" str i)])
    2421                     (when (specialchar? c) (outchr port #\\))
     2438                    (when (eq? c #\|) (outchr port #\\))
    24222439                    (outchr port c)
    24232440                    (loop (fx+ i 1)) ) ) ) ) )
     
    24262443          (let ([len (##sys#size str)])
    24272444            (and (fx> len 0)
    2428                  (not (##core#inline "C_u_i_string_equal_p" "." str))
    2429                  (not (##core#inline "C_u_i_string_equal_p" "#" str))
     2445                 (if (eq? len 1)
     2446                     (case (##core#inline "C_subchar" str 0)
     2447                       ((#\. #\#) #f)
     2448                       (else #t) ) )
    24302449                 (not (##core#inline "C_substring_compare" "#!" str 0 0 2))
    2431                  (let loop ([i (fx- len 1)])
    2432                    (or (fx< i 0)
     2450                 (let loop ((i (fx- len 1)))
     2451                   (if (eq? i 0)
     2452                       (let ((c (##core#inline "C_subchar" str 0)))
     2453                         (cond ((or (char-numeric? c)
     2454                                    (eq? c #\+)
     2455                                    (eq? c #\-)
     2456                                    (eq? c #\.) )
     2457                                (not (##sys#string->number str)) )
     2458                               ((specialchar? c) #f)
     2459                               (else #t) ) )
    24332460                       (let ([c (##core#inline "C_subchar" str i)])
    24342461                         (and (or csp (not (char-upper-case? c)))
     
    24512478                                [(fx< code 32)
    24522479                                 (outchr port #\x)
    2453                                  (outstr port (number->string code 16)) ]
     2480                                 (outstr port (##sys#number->string code 16)) ]
    24542481                                [(fx> code 255)
    24552482                                 (outchr port (if (fx> code #xffff) #\U #\u))
    2456                                  (outstr port (number->string code 16)) ]
     2483                                 (outstr port (##sys#number->string code 16)) ]
    24572484                                [else (outchr port x)] ) ) ]
    24582485                       [else (outchr port x)] ) )
    2459                 ((##core#inline "C_fixnump" x) (outstr port (number->string x)))
     2486                ((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))
    24602487                ((eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    24612488                 (outstr port "#<unbound value>") )
     
    27702797    (lambda () sym) ) )
    27712798
    2772 (define flat-directory-install (##core#inline "C_flat_directory_install"))
     2799(define (flat-directory-install) (##sys#fudge 38))
    27732800
    27742801(define (chicken-version . full)
     
    27982825         " - " (get-config)
    27992826         (if (eq? 0 (##sys#size spec)) "" (string-append " - [" spec " ]") ) ))
    2800       (string-append (number->string build-version) "." (number->string build-number))))
     2827      (string-append (##sys#number->string build-version) "." (##sys#number->string build-number))))
    28012828
    28022829(define ##sys#pathname-directory-separator
     
    32893316
    32903317(define ##sys#error-hook
    3291   (let ([string-append string-append]
    3292         [number->string number->string] )
     3318  (let ([string-append string-append])
    32933319    (lambda (code loc . args)
    32943320      (case code
     
    32993325                ##sys#signal-hook
    33003326                #:arity-error loc
    3301                 (string-append "bad argument count - received " (number->string n) " but expected "
    3302                                (number->string c) )
     3327                (string-append "bad argument count - received " (##sys#number->string n) " but expected "
     3328                               (##sys#number->string c) )
    33033329                (if fn (list fn) '())) ) )
    33043330        ((2) (let ([c (car args)]
     
    33083334                ##sys#signal-hook
    33093335                #:arity-error loc
    3310                 (string-append "too few arguments - received " (number->string n) " but expected "
    3311                                (number->string c) )
     3336                (string-append "too few arguments - received " (##sys#number->string n) " but expected "
     3337                               (##sys#number->string c) )
    33123338                (if fn (list fn) '()))))
    33133339        ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
     
    35473573
    35483574(define (##sys#interrupt-hook reason state)
    3549   (if (fx> (##sys#slot ##sys#pending-finalizers 0) 0)
    3550       (##sys#run-pending-finalizers state)
    3551       (##sys#context-switch state) ) )
     3575  (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)
     3576         (##sys#run-pending-finalizers state) )
     3577        (else (##sys#context-switch state) ) ) )
    35523578
    35533579
  • chicken/lolevel.scm

    r1016 r1186  
    6868    (no-procedure-checks-for-usual-bindings)
    6969    (bound-to-procedure
     70     ##sys#symbol-hash-toplevel-binding? ##sys#make-locative ##sys#become! make-hash-table
     71     hash-table-ref/default ##sys#make-string make-vector hash-table-set! hash-table-set!
     72     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
     73     ##sys#make-pointer byte-vector-fill! make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
     74     ##sys#locative? ##sys#bytevector?
     75     extend-procedure ##sys#lambda-decoration ##sys#decorate-lambda ##sys#make-tagged-pointer ##sys#check-special
    7076     ##sys#vector->closure! ##sys#error ##sys#signal-hook ##sys#address->pointer ##sys#pointer->address) ) ] )
    7177
  • chicken/makefile.vc

    r1016 r1186  
    4040          uextras.c \
    4141          uutils.c uposixwin.c upregexp.c usrfi-4.c tcp.c utcp.c \
    42           chicken.c compiler.c support.c partition.c easyffi.c c-backend.c c-platform.c optimizer.c \
     42          chicken.c compiler.c support.c easyffi.c c-backend.c c-platform.c optimizer.c \
    4343          *.lib *.exe *.exp *.dll
    4444
     
    271271# The compiler:
    272272
    273 chicken.exe : chicken.obj support.obj partition.obj easyffi.obj compiler.obj optimizer.obj batch-driver.obj \
     273chicken.exe : chicken.obj support.obj easyffi.obj compiler.obj optimizer.obj batch-driver.obj \
    274274          c-platform.obj c-backend.obj chicken.res \
    275275          libchicken.lib
    276276        link $(LFLAGS) $** /out:$@
    277277
    278 chicken-static.exe : chicken.obs support.obs partition.obs easyffi.obs compiler.obs optimizer.obs batch-driver.obs \
     278chicken-static.exe : chicken.obs support.obs easyffi.obs compiler.obs optimizer.obs batch-driver.obs \
    279279          c-platform.obs c-backend.obs chicken.res \
    280280          libchicken-static.lib
     
    288288support.obj : support.c chicken.h
    289289support.obs : support.c chicken.h
    290 partition.obj : partition.c chicken.h
    291 partition.obs : partition.c chicken.h
    292290easyffi.obj : easyffi.c chicken.h
    293291easyffi.obs : easyffi.c chicken.h
  • chicken/misc/wwchicken.scm

    r1063 r1186  
    213213                         (li "SRFI 55 (" (tt "require-extension") ")")
    214214                         (li "SRFI 57 (Records) &deg;")
     215                         (li "SRFI 60 (Integers as bits) &deg;")
    215216                         (li "SRFI 61 (a more general " (tt "cond") " clause)")
    216217                         (li "SRFI 62 (S-Expression comments)")
  • chicken/optimizer.scm

    r1016 r1186  
    4747  foreign-declarations emit-trace-info block-compilation analysis-database-size line-number-database-size
    4848  always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
    49   target-heap-size target-stack-size
     49  target-heap-size target-stack-size constant-declarations
    5050  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    5151  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
     
    305305                           (touch)
    306306                           (walk (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f)) ) ]
     307                        [(memq var constant-declarations)
     308                         (or (and-let* ((k (car args))
     309                                        ((eq? '##core#variable (node-class k)))
     310                                        (kvar (first (node-parameters k)))
     311                                        (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
     312                                        (eq? '##core#lambda (node-class lval))
     313                                        (llist (third (node-parameters lval)))
     314                                        ((or (test (car llist) 'unused)
     315                                             (and (not (test (car llist) 'references))
     316                                                  (not (test (car llist) 'assigned)))))
     317                                        ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
     318                               (debugging 'x "removed call to constant procedure with unused result" var)
     319                               (make-node
     320                                '##core#call '(#t)
     321                                (list k (make-node '##core#undefined '() '())) ) )
     322                             (walk-generic n class params subs)) ]
    307323                        [(and lval (eq? '##core#lambda (node-class lval)))
    308324                         (let* ([lparams (node-parameters lval)]
  • chicken/parameters.scm

    r1016 r1186  
    111111
    112112(define-constant builtin-features/compiled
    113   '(srfi-11 srfi-8 srfi-6 srfi-16 srfi-15 srfi-26 srfi-55 srfi-9 srfi-17) )
     113  '(easyffi srfi-11 srfi-8 srfi-6 srfi-16 srfi-15 srfi-26 srfi-55 srfi-9 srfi-17) )
    114114
    115115(define-constant installed-executables
  • chicken/pcre.scm

    r1016 r1186  
    6161    (no-bound-checks)
    6262    (no-procedure-checks-for-usual-bindings)
    63     ;(no-procedure-checks)
    6463    ) ] )
    6564
  • chicken/posix.scm

    r1016 r1186  
    345345    (bound-to-procedure
    346346     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
    347      ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer
     347     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer make-pathname glob directory?
     348     pathname-file string-match process-fork file-close duplicate-fileno process-execute getenv
     349     make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
     350     process-wait pathname-strip-directory ##sys#expand-home-path glob->regexp directory
     351     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
     352     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
     353     current-directory ##sys#make-pointer port? ##sys#schedule
    348354     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )
    349355
     
    508514 [else
    509515  (define file-mkstemp
    510     (let ([string-length string-length])
    511       (lambda (template)
    512         (##sys#check-string template 'file-mkstemp)
    513         (let* ([buf (##sys#make-c-string template)]
    514                [fd (##core#inline "C_mkstemp" buf)]
    515                [path-length (string-length buf)])
    516           (when (eq? -1 fd)
    517                 (posix-error #:file-error 'file-mkstemp "can not create temporary file" template) )
    518           (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) ) ] )
     516    (lambda (template)
     517      (##sys#check-string template 'file-mkstemp)
     518      (let* ([buf (##sys#make-c-string template)]
     519             [fd (##core#inline "C_mkstemp" buf)]
     520             [path-length (##sys#size buf)])
     521        (when (eq? -1 fd)
     522          (posix-error #:file-error 'file-mkstemp "can not create temporary file" template) )
     523        (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) ] )
    519524
    520525
     
    15511556              (let-values ([(dir file ext) (decompose-pathname path)])
    15521557                (let ([rx (glob->regexp (make-pathname #f (or file "*") ext))])
    1553                   (let loop ([f (directory (or dir "."))])
     1558                  (let loop ([f (directory (or dir ".") #t)])
    15541559                    (cond [(null? f) (conc (cdr paths))]
    15551560                          [(string-match rx (car f))
  • chicken/profiler.scm

    r1016 r1186  
    4545 [else
    4646  (declare
     47    (bound-to-procedure
     48     write-char write make-vector)
    4749    (no-bound-checks) ) ] )
    4850
  • chicken/regex-common.scm

    r1016 r1186  
    3232; 37130 Gleichen
    3333; Germany
     34
     35
     36(declare
     37  (bound-to-procedure
     38   get-output-string open-output-string ##sys#write-char-0 string-search string->list list->string
     39   ##sys#substring string-search-positions reverse ##sys#fragments->string substring make-string
     40   string-substitute
     41   ##sys#signal-hook string-append ##sys#make-c-string set-finalizer! ##sys#string-append) )
    3442
    3543
  • chicken/regex.scm

    r1016 r1186  
    6363  (declare
    6464    (no-bound-checks)
     65    (no-procedure-checks-for-usual-bindings)
    6566    (bound-to-procedure
    6667     ##sys#check-string ##sys#check-exact ##sys#make-pointer ##sys#cons ##sys#size ##sys#slot
  • chicken/runtime.c

    r1063 r1186  
    246246                                     else v = C_flonum_magnitude(x);
    247247#endif
     248
     249#define C_isnan(f)                   (!((f) == (f)))
     250#define C_isinf(f)                   ((f) == (f) + (f) && (f) != 0.0)
     251
    248252
    249253/* these could be shorter in unsafe mode: */
     
    959963}
    960964
     965
    961966/* This is called from POSIX signals: */
    962967
     
    966971  signal(signum, global_signal_handler);
    967972}
     973
    968974
    969975/* Modify heap size at runtime: */
     
    32763282          if(is_fptr(h)) {      /* secondary forwarding check for pointed-at object */
    32773283            ptr2 = (C_uword)fptr_to_ptr(h) + offset;
    3278             assert(!is_fptr(C_block_header(ptr2)));
    32793284            C_set_block_item(loc, 0, ptr2);
    32803285          }
     
    40144019#endif
    40154020
     4021  case C_fix(38):
     4022    /* By Brandon Van Every: */
     4023    /* vcbuild.bat is the only build that installs everything
     4024       in a flat directory.  It doesn't pass any defines, so
     4025       msvc is installed flat by default.  CMake passes
     4026       HIERARCHICAL_INSTALL so that it can bypass the default
     4027       behavior for msvc. ./configure never builds with msvc. */
     4028#if defined(_MSC_VER) && !defined(HIERARCHICAL_INSTALL)
     4029    return C_SCHEME_TRUE;
     4030#else
     4031    return C_SCHEME_FALSE;
     4032#endif
     4033
    40164034  default: return C_SCHEME_UNDEFINED;
    40174035  }
    4018 }
    4019 
    4020 /* By Brandon Van Every: */
    4021 C_regparm C_word C_fcall C_flat_directory_install()
    4022 {
    4023   /* vcbuild.bat is the only build that installs everything
    4024   in a flat directory.  It doesn't pass any defines, so
    4025   msvc is installed flat by default.  CMake passes
    4026   HIERARCHICAL_INSTALL so that it can bypass the default
    4027   behavior for msvc. ./configure never builds with msvc. */
    4028 #if defined(_MSC_VER) && !defined(HIERARCHICAL_INSTALL)
    4029   return C_SCHEME_TRUE;
    4030 #else
    4031   return C_SCHEME_FALSE;
    4032 #endif
    40334036}
    40344037
     
    73317334  C_char *eptr, *eptr2;
    73327335  double fn;
     7336#ifdef __CYGWIN__
     7337  int len = C_strlen(str);
     7338
     7339  if(len >= 4) {
     7340    if(!C_strncmp(str, "+nan.0", len)) {
     7341      *flo = 0.0/0.0;
     7342      return 2;
     7343    }
     7344    else if(!C_strncmp(str, "+inf.0", len)) {
     7345      *flo = 1.0/0.0;
     7346      return 2;
     7347    }
     7348    else if(!C_strncmp(str, "-inf.0", len)) {
     7349      *flo = -1.0/0.0;
     7350      return 2;
     7351    }
     7352  }
     7353#endif
    73337354
    73347355  if(C_strpbrk(str, "xX\0") != NULL) return 0;
     
    73537374    if(fn == HUGE_VAL && errno == ERANGE) return 0;
    73547375    else if(eptr2 == str) return 0;
    7355     else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr, ".0", C_strlen(eptr2)))) {
     7376    else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr2, ".0", C_strlen(eptr2)))) {
    73567377      *flo = fn;
    73577378      return 2;
     
    74477468    }
    74487469
     7470#ifdef __CYGWIN__
     7471    if(C_isnan(f)) {
     7472      C_strcpy(p = buffer, "+nan.0");
     7473      goto fini;
     7474    }
     7475    else if(C_isinf(f)) {
     7476      C_sprintf(p = buffer, "%cinf.0", f > 0 ? '+' : '-');
     7477      goto fini;
     7478    }
     7479#endif
     7480
    74497481#ifdef HAVE_GCVT
    74507482    C_gcvt(f, FLONUM_PRINT_PRECISION, buffer);
     
    77747806{
    77757807  C_word n = C_header_size(state) - 1,
    7776          adrs = C_u_i_car(state);
     7808    adrs = C_block_item(state, 0);
    77777809  TRAMPOLINE trampoline;
    77787810
  • chicken/srfi-1.scm

    r1016 r1186  
    3535  (declare
    3636    (no-procedure-checks-for-usual-bindings)
     37    (bound-to-procedure
     38     every any partition! reduce lset-difference! append! pair-fold lset-diff+intersection! fold
     39     lset-difference filter! filter delete span! span find-tail find delete! pair-for-each car+cdr
     40     reduce-right last-pair drop)
    3741    (no-bound-checks) ) ] )
    3842
  • chicken/srfi-13.scm

    r1016 r1186  
    3737  (declare
    3838    (no-procedure-checks-for-usual-bindings)
     39    (bound-to-procedure
     40     string-concatenate check-substring-spec ##srfi13#string-fill! string-parse-final-start+end
     41     ##sys#substring string-index-right string-skip-right substring/shared
     42     string-concatenate/shared make-kmp-restart-vector string-ci= string= char-set?
     43     char-set-contains? string-fold char-set string-skip string-index string-downcase! char->int
     44     string-parse-start+end substring-spec-ok?)
    3945    (no-bound-checks) ) ] )
    4046
  • chicken/srfi-14.scm

    r1016 r1186  
    1818  (declare
    1919    (no-procedure-checks-for-usual-bindings)
     20    (bound-to-procedure
     21     char-set char-set-complement ucs-range->char-set! ucs-range->char-set char-set-union
     22     char-set-adjoin string->char-set list->char-set string-copy make-char-set char-set-copy
     23     char-set? char-set-size char-set:s)
    2024    (no-bound-checks) ) ] )
    2125
  • chicken/srfi-18.scm

    r1016 r1186  
    4949    (no-procedure-checks-for-usual-bindings)
    5050    (bound-to-procedure
     51     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
     52     ##sys#thread-basic-unblock! gensym ##sys#thread-block-for-timeout! ##sys#thread-kill!
     53     ##sys#thread-block-for-termination! make-thread ##sys#exact->inexact ##sys#flonum-fraction truncate
    5154     ##sys#add-to-ready-queue
    5255     ##sys#schedule ##sys#make-thread
  • chicken/srfi-4.scm

    r1016 r1186  
    8181     ##sys#u16vector-ref ##sys#u16vector-set!
    8282     ##sys#s16vector-ref ##sys#s16vector-set! ##sys#u32vector-ref ##sys#u32vector-set! ##sys#s32vector-ref
    83      ##sys#s32vector-set!
     83     ##sys#s32vector-set! read list->f64vector list->s32vector list->u32vector list->u16vector list-s8vector
     84     list->u8vector set-finalizer!
    8485     ##sys#f32vector-ref ##sys#f32vector-set! ##sys#f64vector-ref ##sys#f64vector-set! ##sys#check-exact-interval
    8586     ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#cons-flonum ##sys#check-list
  • chicken/support.scm

    r1016 r1186  
    7575  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    7676  foreign-argument-conversion foreign-result-conversion final-foreign-type debugging export-list block-globals
    77   lookup-exports-file
     77  lookup-exports-file constant-declarations
    7878  make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration}
    7979
     
    807807             ((file-exists? xfile)) )
    808808    (when verbose-mode
    809       (printf "loading ~a ...~%" xfile) )
     809      (printf "loading exports file ~a ...~%" xfile) )
    810810    (for-each (cut ##sys#hash-table-set! import-table <> id) (read-file xfile)) ) )
    811811
     
    12191219
    12201220    -output-file FILENAME       specifies output-filename, default is 'out.c'
    1221     -split NUMBER               split the output into smaller files
    1222     -split-level NUMBER         how hard the compiler should try partitioning the output
    12231221    -include-path PATHNAME      specifies alternative path for included files
    12241222    -to-stdout                  write compiled file to stdout instead of file
     
    12571255    -emit-exports FILENAME      write exported toplevel variables to FILENAME
    12581256    -check-imports              look for undefined toplevel variables
     1257    -import FILENAME            read externally exported symbols from FILENAME
    12591258
    12601259  Optimization options:
  • chicken/tcp.scm

    r1016 r1186  
    4444  (no-procedure-checks-for-usual-bindings)
    4545  (bound-to-procedure
    46    ##net#socket ##net#bind ##net#connect ##net#listen ##net#accept
     46   ##net#socket ##net#bind ##net#connect ##net#listen ##net#accept make-parameter ##sys#string-append ##sys#tcp-port->fileno
     47   ##sys#check-port ##sys#port-data ##sys#thread-block-for-i/o! make-string make-input-port make-output-port ##sys#substring
     48   substring ##sys#make-c-string ##sys#schedule
    4749   ##net#close ##net#recv ##net#send ##net#select ##net#select-write ##net#gethostaddr ##net#io-ports ##sys#update-errno
    4850   ##sys#error ##sys#signal-hook ##net#getservbyname ##net#parse-host ##net#fresh-addr
  • chicken/tests/locative-stress-test.scm

    r1063 r1186  
    33(declare (usual-integrations))
    44
    5 (set-gc-report! #t)
     5;(set-gc-report! #t)
    66
    77(require-extension srfi-1)
     
    4242      ((i (string->number (:optional (command-line-arguments) "100000"))))
    4343    (unless (eq? i 0)
    44       (let-location ((o0 long 0) (o1 long 0) (o2 long 0) (o3 long 0) (o4 long 0)
    45                      (o5 long 0) (o6 long 0) (o7 long 0) (o8 long 0) (o9 long 0))
     44      (let-location ((o0 long) (o1 long) (o2 long) (o3 long) (o4 long)
     45                     (o5 long) (o6 long) (o7 long) (o8 long) (o9 long))
    4646        (fill-10! el #$o0 #$o1 #$o2 #$o3 #$o4 #$o5 #$o6 #$o7 #$o8 #$o9)
    4747        (let ((result (list o0 o1 o2 o3 o4 o5 o6 o7 o8 o9)))
  • chicken/tinyclos.scm

    r1016 r1186  
    6565    (no-procedure-checks-for-usual-bindings)
    6666    (bound-to-procedure
    67      every1 every2 getl filter-in ensure-generic add-global-method
     67     every1 every2 getl filter-in ensure-generic add-global-method gensym make make-generic
     68     make-method compute-apply-methods compute-methods add-method class-of compute-method-morre-specific?
     69     call-next-method ##sys#symbol->string compute-cpl compute-slots compute-getter-and-setter
     70     fprintf slot-ref subclass? slot-set! allocate-instance compute-apply-generic class-slots
     71     class-direct-supers port? input-port? ##sys#bytevector?
    6872     compute-std-cpl top-sort std-tie-breaker build-transitive-closure build-constraints
    6973     %allocate-instance %allocate-entity get-field set-field! lookup-slot-info
  • chicken/utils.scm

    r1016 r1186  
    4848  (declare
    4949    (no-procedure-checks-for-usual-bindings)
     50    (bound-to-procedure
     51      ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
     52      for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
     53      decompose-pathname string-search absolute-pathname? string-append ##sys#substring string-match
     54      delete-file system)
    5055    (no-bound-checks))] )
    5156
  • fp/doc.scm

    r333 r1186  
    159159     "Example"
    160160     (pre #<<EOF
    161   /* fac.fp
    162      usage: fpi fac.fp
    163   */
     161  /* fac.fp */
    164162
    165163  fac == eq0 -> ~1; x ° [id, fac ° sub1]
  • fp/fp.html

    r333 r1186  
    114114<div id="header">
    115115<h2>fp</h2>
    116 <div id="eggheader">
    117 <a href="index.html">
     116<div id="eggheader"><a href="index.html">
    118117<img src="egg.jpg" alt="[Picture of an egg]" /></a></div></div>
    119118<div id="body">
     
    122121<p>An interpreter/translator for a dialect of John Backus' FP language</p></div>
    123122<div class="section">
    124 <h3>Author</h3>
    125 <a href="mailto:felix@call-with-current-continuation.org">felix</a></div>
     123<h3>Author</h3><a href="mailto:felix@call-with-current-continuation.org">felix</a></div>
    126124<div class="section">
    127125<h3>Version</h3>
     
    131129<h3>Requires</h3>
    132130<ul>
    133 <li>
    134 <a href="silex.html">silex</a></li>
    135 <li>
    136 <a href="lalr.html">lalr</a></li></ul></div>
    137 <div class="section">
    138 <h3>Usage</h3>
    139 <tt>(require-extension fp)</tt></div>
    140 <div class="section">
    141 <h3>Download</h3>
    142 <a href="fp.egg">fp.egg</a></div>
     131<li><a href="silex.html">silex</a></li>
     132<li><a href="lalr.html">lalr</a></li></ul></div>
     133<div class="section">
     134<h3>Usage</h3><tt>(require-extension fp)</tt></div>
     135<div class="section">
     136<h3>Download</h3><a href="fp.egg">fp.egg</a></div>
    143137<div class="section">
    144138<h3>Documentation</h3>
     
    146140<h3>Introduction</h3>
    147141<p>This extension translates programs in a dialect of the FP programming language into Scheme. You can use the translator interactively, as a library or as a compiler extension (the latter allows you to compile FP code into executables and/or libraries).</p>
    148 <p>To use it interactively, invoke the
    149 <tt>fp-repl</tt> procedure (see below). To use it as a library, call
    150 <tt>fp-eval</tt>.</p>
    151 <p>If you want to compile FP programs, pass the
    152 <tt>-X fp</tt> option to the CHICKEN compiler driver, like this:
     142<p>To use it interactively, invoke the <tt>fp-repl</tt> procedure (see below). To use it as a library, call <tt>fp-eval</tt>.</p>
     143<p>If you want to compile FP programs, pass the <tt>-X fp</tt> option to the CHICKEN compiler driver, like this:
    153144<pre>% csc -X fp myprogram.fp</pre></p>
    154145<p>A program consists of a list of definitions, like this:</p>
     
    156147main   == square ° tonum
    157148</pre>
    158 <p>The left hand side of a definition specifies a name and the right hand side should be a functional form. A definition may be followed by auxilliary definitions enclosed in
    159 <tt>{ ... }</tt> which are only visible in the preceding  definition.</p>
    160 <p>Identifiers may consist of lowercase letters, the
    161 <tt>'</tt> character or an underscore. Any character with an ASCII/ISO-8859-1 code below or equal 32 is ignored. Any other character is treated as an identifier of length 1.</p>
    162 <p>Comments follow C-style (
    163 <tt>/* ... */</tt>) and may not be nested.
    164 <tt>#!</tt> is also parsed as a comment and ignores everything up to the next line.</p></div>
     149<p>The left hand side of a definition specifies a name and the right hand side should be a functional form. A definition may be followed by auxilliary definitions enclosed in <tt>{ ... }</tt> which are only visible in the preceding  definition.</p>
     150<p>Identifiers may consist of lowercase letters, the <tt>'</tt> character or an underscore. Any character with an ASCII/ISO-8859-1 code below or equal 32 is ignored. Any other character is treated as an identifier of length 1.</p>
     151<p>Comments follow C-style (<tt>/* ... */</tt>) and may not be nested.<tt>#!</tt> is also parsed as a comment and ignores everything up to the next line.</p></div>
    165152<div class="section">
    166153<h3>Objects</h3>
    167 <p>An object is an atom (a symbol consisting of uppercase characters or
    168 <tt>_</tt>, a character (
    169 <tt>'char</tt>) a sequence (
    170 <tt>&lt;x1, ...&gt;</tt>), a character sequence
    171 <tt>&quot; ... &quot;</tt> or a number. The atom
    172 <tt>F</tt> is also used as the boolean false value.</p>
    173 <p>If the
    174 <a href="http://www.call-with-current-continuation.org/eggs/numbers.html">numbers</a> extension is loaded, then FP programs are capable of calcluating with bignums and exact rationals.</p></div>
     154<p>An object is an atom (a symbol consisting of uppercase characters or <tt>_</tt>, a character (<tt>'char</tt>) a sequence (<tt>&lt;x1, ...&gt;</tt>), a character sequence <tt>&quot; ... &quot;</tt> or a number. The atom <tt>F</tt> is also used as the boolean false value.</p>
     155<p>If the <a href="http://www.call-with-current-continuation.org/eggs/numbers.html">numbers</a> extension is loaded, then FP programs are capable of calcuating with bignums and exact rationals.</p></div>
    175156<div class="section">
    176157<h3>Builtin functions</h3>
     
    250231<div class="section">
    251232<h3>Example</h3>
    252 <pre>  /* fac.fp
    253      usage: fpi fac.fp
    254   */
     233<pre>  /* fac.fp */
    255234
    256235  fac == eq0 -&gt; ~1; x ° [id, fac ° sub1]
     
    262241<h3>API</h3>
    263242<dl>
    264 <dt class="definition">
    265 <strong>procedure:</strong> (fp-parse INPUT)</dt>
     243<dt class="definition"><strong>procedure:</strong> (fp-parse INPUT)</dt>
    266244<dd>
    267 <p>Parses the FP code given in
    268 <tt>INPUT</tt>, which should be a string or an input port and returns its Scheme representation as a list of Scheme toplevel expressions.</p>
     245<p>Parses the FP code given in <tt>INPUT</tt>, which should be a string or an input port and returns its Scheme representation as a list of Scheme toplevel expressions.</p>
    269246<p>This Scheme code can be directly evaluated.</p></dd>
    270 <dt class="definition">
    271 <strong>procedure:</strong> (fp-eval INPUT)</dt>
     247<dt class="definition"><strong>procedure:</strong> (fp-eval INPUT)</dt>
    272248<dd>
    273 <p>Parses and evaluates the FP code given in
    274 <tt>INPUT</tt>.</p></dd>
    275 <dt class="definition">
    276 <strong>procedure:</strong> (fp-repl [PROMPT]</dt>
     249<p>Parses and evaluates the FP code given in <tt>INPUT</tt>.</p></dd>
     250<dt class="definition"><strong>procedure:</strong> (fp-repl [PROMPT]</dt>
    277251<dd>
    278 <p>Executes a read-eval-print-loop that prints
    279 <tt>PROMPT</tt>, reads a line of FP code and evaluates it, printing the returned result.</p></dd></dl></div>
     252<p>Executes a read-eval-print-loop that prints <tt>PROMPT</tt>, reads a line of FP code and evaluates it, printing the returned result.</p></dd></dl></div>
    280253<div class="section">
    281254<h3>Interfacing to/from Scheme</h3>
    282 <p>All top-level definitions in FP will result in a Scheme procedure definition of a procedure of one argument, with the name prefixed with
    283 <tt>fp:</tt>, so for example</p>
     255<p>All top-level definitions in FP will result in a Scheme procedure definition of a procedure of one argument, with the name prefixed with <tt>fp:</tt>, so for example</p>
    284256<pre>fac == /x ° !</pre>
    285 <p>will result in a procedure named
    286 <tt>fp:fac</tt> that you can call from Scheme like any other procedure.</p>
    287 <p>FP programs can call Scheme procedures, provided they have a name with the
    288 <tt>fp:</tt> prefix and accept a single argument, returning a single value and accept/return values that are meaningful in FP programs. Scheme and FP data types are related in the following manner:</p>
     257<p>will result in a procedure named <tt>fp:fac</tt> that you can call from Scheme like any other procedure.</p>
     258<p>FP programs can call Scheme procedures, provided they have a name with the <tt>fp:</tt> prefix and accept a single argument, returning a single value and accept/return values that are meaningful in FP programs. Scheme and FP data types are related in the following manner:</p>
    289259<table>
    290260<tr>
     
    305275<div class="section">
    306276<h3>Standard library</h3>
    307 <p>A small library of useful functions is installed in the CHICKEN extension repository under the name
    308 <tt>stdlib.fp</tt>, which you can access by putting
    309 <tt>load:&quot;stdlib.fp&quot;</tt> at the start of your FP program.</p></div>
     277<p>A small library of useful functions is installed in the CHICKEN extension repository under the name <tt>stdlib.fp</tt>, which you can access by putting <tt>load:&quot;stdlib.fp&quot;</tt> at the start of your FP program.</p></div>
    310278<div class="section">
    311279<h3>References</h3>
     
    333301OTHER DEALINGS IN THE SOFTWARE.</pre></div></div></div></div></div>
    334302<div id="footer">
    335 <hr />
    336 <a href="index.html">&lt; Egg index</a>
     303<hr /><a href="index.html">&lt; Egg index</a>
    337304<div id="revision-history">$Revision$ $Date$</div>&nbsp;</div></body></html>
  • mailbox/mailbox.html

    r852 r1186  
    1717<h3>Version:</h3>
    1818<ul>
     19<li>1.4
     20Added thread safe internal queue implementation
    1921<li>1.3
    2022<code>queue-push-back[-list]!</code> contributed by Graham Fawcett
     
    5759<dd>Pushes an item into the first position of a mailbox.
    5860
    59 <dt><pre><b>[procedure] (mailbox--push-back-list! MAILBOX LIST)</b></pre>
     61<dt><pre><b>[procedure] (mailbox-push-back-list! MAILBOX LIST)</b></pre>
    6062<dd>Pushes the items in item-list back into the mailbox,
    6163so that <code>(car LIST)</code> becomes the next receivable item.
  • mailbox/mailbox.scm

    r852 r1186  
    3737  (disable-interrupts)
    3838  (no-bound-checks)
     39  (export make-mailbox mailbox-name mailbox-send! mailbox-wait! mailbox-push-back!
     40          mailbox-push-back-list! mailbox-receive! mailbox-empty? mailbox?)
     41  (uses srfi-18)
    3942  (fixnum) )
    4043
    41 (require 'extras 'srfi-18)
    4244
     45(define (make-queue) (##sys#make-structure 'queue '() '()))
     46
     47(define (queue-empty? q)
     48  (eq? '() (##sys#slot q 1)) )
     49
     50(define (queue-add! q datum)
     51  (let ((new-pair (cons datum '())))
     52    (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
     53          (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
     54    (##sys#setslot q 2 new-pair) ) )
     55
     56(define queue-remove!
     57  (lambda (q)
     58    (let ((first-pair (##sys#slot q 1)))
     59      (let ((first-cdr (##sys#slot first-pair 1)))
     60        (##sys#setslot q 1 first-cdr)
     61        (if (eq? '() first-cdr)
     62            (##sys#setslot q 2 '()) )
     63        (##sys#slot first-pair 0) ) ) ) )
     64
     65(define (queue-push-back! q item)
     66  (let ((newlist (cons item (##sys#slot q 1))))
     67    (##sys#setslot q 1 newlist)
     68    (if (eq? '() (##sys#slot q 2))
     69        (##sys#setslot q 2 newlist))))
     70
     71(define-macro (last-pair lst0)
     72  `(do ((lst ,lst0 (##sys#slot lst 1)))
     73       ((eq? (##sys#slot lst 1) '()) lst)))
     74
     75(define (queue-push-back-list! q itemlist)
     76  (let* ((newlist (append itemlist (##sys#slot q 1)))
     77         (newtail (if (eq? newlist '())
     78                       '()
     79                       (last-pair newlist))))
     80    (##sys#setslot q 1 newlist)
     81    (##sys#setslot q 2 newtail)))
    4382
    4483(define (make-mailbox . name)
     
    77116  (queue-empty? (##sys#slot ch 1)) )
    78117
    79 (define mailbox-ready? mailbox-empty?)  ; deprecated
    80 
    81118; (mailbox-push-back! mb item)
    82119; Pushes an item into the first position of a mb.
Note: See TracChangeset for help on using the changeset viewer.